Retropikzel
/
foreign-c
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Make pffi-size-of work with structs too

This commit is contained in:
retropikzel 2025-02-17 20:03:55 +02:00
parent a35dc8dbc8
commit 7b12ab40cb
23 changed files with 164 additions and 98 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
README.md
View File

@ -40,7 +40,6 @@ Any help in form of constructive advice and bug reports are appreciated.
- [pffi-string->pointer](#strongpffi-string-gtpointerstrong-string--gt-pointer) - [pffi-string->pointer](#strongpffi-string-gtpointerstrong-string--gt-pointer)
- [pffi-pointer->string](#strongpffi-pointer-gtstringstrong-pointer--gt-string) - [pffi-pointer->string](#strongpffi-pointer-gtstringstrong-pointer--gt-string)
- [pffi-struct-make](#strongpffi-struct-makestrong-name-members--pointer--gt-pffi-struct) - [pffi-struct-make](#strongpffi-struct-makestrong-name-members--pointer--gt-pffi-struct)
- [pffi-struct-size](#strongpffi-struct-sizestrong-pffi-struct--gt-number)
- [pffi-struct-pointer](#strongpffi-struct-pointerstrong-pffi-struct--gt-pointer) - [pffi-struct-pointer](#strongpffi-struct-pointerstrong-pffi-struct--gt-pointer)
- [pffi-struct-offset-get](#strongpffi-struct-offset-getstrong-member-name--gt-number) - [pffi-struct-offset-get](#strongpffi-struct-offset-getstrong-member-name--gt-number)
- [pffi-struct-get](#strongpffi-struct-getstrong-pffi-struct-member-name--gt-object) - [pffi-struct-get](#strongpffi-struct-getstrong-pffi-struct-member-name--gt-object)
@ -76,28 +75,28 @@ changing anymore and some implementations are in **beta**.
### Beta ### Beta
| | pffi-init | pffi-size-of | pffi-shared-object-auto-load | pffi-shared-object-load | pffi-pointer-null | pffi-pointer-null? | pffi-pointer-allocate | pffi-pointer-address | pffi-pointer? | pffi-pointer-free | pffi-pointer-set! | pffi-pointer-get | pffi-string->pointer | pffi-pointer->string | pffi-struct-make | pffi-struct-size | pffi-struct-pointer | pffi-struct-offset-get | pffi-struct-get | pffi-struct-set! | pffi-struct-dereference | pffi-define | pffi-define-callback | | | pffi-init | pffi-size-of | pffi-shared-object-auto-load | pffi-shared-object-load | pffi-pointer-null | pffi-pointer-null? | pffi-pointer-allocate | pffi-pointer-address | pffi-pointer? | pffi-pointer-free | pffi-pointer-set! | pffi-pointer-get | pffi-string->pointer | pffi-pointer->string | pffi-struct-make | pffi-struct-pointer | pffi-struct-offset-get | pffi-struct-get | pffi-struct-set! | pffi-struct-dereference | pffi-define | pffi-define-callback |
|--------------|-----------|--------------|------------------------------|-------------------------|-------------------|--------------------|-----------------------|----------------------|---------------|-------------------|-------------------|------------------|----------------------|----------------------|------------------|------------------|---------------------|------------------------|-----------------|------------------|-------------------------|-------------|----------------------| |--------------|-----------|--------------|------------------------------|-------------------------|-------------------|--------------------|-----------------------|----------------------|---------------|-------------------|-------------------|------------------|----------------------|----------------------|------------------|---------------------|------------------------|-----------------|------------------|-------------------------|-------------|----------------------|
| Guile | X | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | | Guile | X | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | X | X | X |
| Racket | X | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | | Racket | X | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | X | X | X |
| Saggittarius | X | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | | Saggittarius | X | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | X | X | X |
### Alpha ### Alpha
| | pffi-init | pffi-size-of | pffi-shared-object-auto-load | pffi-shared-object-load | pffi-pointer-null | pffi-pointer-null? | pffi-pointer-allocate | pffi-pointer-address |pffi-pointer? | pffi-pointer-free | pffi-pointer-set! | pffi-pointer-get | pffi-string->pointer | pffi-pointer->string | pffi-struct-make | pffi-struct-size | pffi-struct-pointer | pffi-struct-offset-get | pffi-struct-get | pffi-struct-set! | pffi-struct-dereference | pffi-define | pffi-define-callback | | | pffi-init | pffi-size-of | pffi-shared-object-auto-load | pffi-shared-object-load | pffi-pointer-null | pffi-pointer-null? | pffi-pointer-allocate | pffi-pointer-address |pffi-pointer? | pffi-pointer-free | pffi-pointer-set! | pffi-pointer-get | pffi-string->pointer | pffi-pointer->string | pffi-struct-make | pffi-struct-pointer | pffi-struct-offset-get | pffi-struct-get | pffi-struct-set! | pffi-struct-dereference | pffi-define | pffi-define-callback |
|--------------|-----------|--------------|------------------------------|-------------------------|-------------------|--------------------|-----------------------|----------------------|---------------|-------------------|-------------------|------------------|----------------------|----------------------|------------------|------------------|---------------------|------------------------|-----------------|------------------|-------------------------|-------------|----------------------| |--------------|-----------|--------------|------------------------------|-------------------------|-------------------|--------------------|-----------------------|----------------------|---------------|-------------------|-------------------|------------------|----------------------|----------------------|------------------|---------------------|------------------------|-----------------|------------------|-------------------------|-------------|----------------------|
| Chibi | X | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | X | | X | | | Chibi | X | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | | X | |
| Chicken-5 | X | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | X | | X | X | | Chicken-5 | X | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | | X | X |
| Cyclone | X | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | X | | X | | | Cyclone | X | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | | X | |
| Gambit | X | X | | | | | | | | | | | | | X | X | X | X | X | X | | | | | Gambit | X | X | | | | | | | | | | | | | X | X | X | X | X | | | |
| Gauche | X | | | | | | | | | | | | | | X | X | X | X | X | X | | | | | Gauche | X | | | | | | | | | | | | | | X | X | X | X | X | | | |
| Gerbil | X | | | | | | | | | | | | | | X | X | X | X | X | X | | | | | Gerbil | X | | | | | | | | | | | | | | X | X | X | X | X | | | |
| Larceny | X | | | | | | | | | | | | | | X | X | X | X | X | X | | | | | Larceny | X | | | | | | | | | | | | | | X | X | X | X | X | | | |
| Mosh | X | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | | Mosh | X | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | X | X | X |
| Skint | X | | | | | | | | | | | | | | X | X | X | X | X | X | | | | | Skint | X | | | | | | | | | | | | | | X | X | X | X | X | | | |
| Stklos | X | X | X | X | X | X | X | | X | X | | | | | X | X | X | X | X | X | | | | | Stklos | X | X | X | X | X | X | X | | X | X | | | | | X | X | X | X | X | | | |
| tr7 | | | | | | | | | | | | | | | X | X | X | X | X | X | | | | | tr7 | | | | | | | | | | | | | | | X | X | X | X | X | | | |
| Ypsilon | | | | | | | | | | | | | | | X | X | X | X | X | X | | | | | Ypsilon | | | | | | | | | | | | | | | X | X | X | X | X | | | |
### Not started ### Not started
@ -187,9 +186,9 @@ Some of these are procedures and some macros, it might also change implementatio
Always call this first, on most implementation it does nothing but some implementations might need Always call this first, on most implementation it does nothing but some implementations might need
initialisation run. initialisation run.
##### **pffi-size-of** type -> number ##### **pffi-size-of** object -> number
Returns the size of the type. Returns the size of the pffi-struct, pffi-enum or pffi-type.
##### **pffi-align-of** type -> number ##### **pffi-align-of** type -> number
@ -294,14 +293,6 @@ names and types. For example:
C-type argument can be symbol or a string. C-type argument can be symbol or a string.
##### **pffi-struct-size** pffi-struct -> number
Returns the size of a given pffi-struct. For example:
(define s (pffi-struct-make 'test '((int . r) (int . g) (int . b))))
(pffi-struct-size s)
> 12
##### **pffi-struct-pointer** pffi-struct -> pointer ##### **pffi-struct-pointer** pffi-struct -> pointer
Returns the pointer that holds the struct content. You need to use this when passing a struct as Returns the pointer that holds the struct content. You need to use this when passing a struct as

6
manifest.scm
View File

@ -2,4 +2,8 @@
;; You can store it in a file that you may then pass to any 'guix' command ;; You can store it in a file that you may then pass to any 'guix' command
;; that accepts a '--manifest' (or '-m') option. ;; that accepts a '--manifest' (or '-m') option.
(specifications->manifest (list "gcc-toolchain")) (specifications->manifest (list "gcc-toolchain"
"guile-next"
"racket"
"chicken"
"stklos"))

37
retropikzel/r7rs-pffi.sld
View File

@ -11,6 +11,7 @@
(chibi)) (chibi))
(export pffi-init (export pffi-init
pffi-size-of pffi-size-of
pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-shared-object-auto-load
pffi-shared-object-load pffi-shared-object-load
@ -24,7 +25,6 @@
pffi-string->pointer pffi-string->pointer
pffi-pointer->string pffi-pointer->string
pffi-struct-make pffi-struct-make
pffi-struct-size
pffi-struct-pointer pffi-struct-pointer
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
@ -46,6 +46,7 @@
(chicken random)) (chicken random))
(export pffi-init (export pffi-init
pffi-size-of pffi-size-of
pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-shared-object-auto-load
pffi-shared-object-load pffi-shared-object-load
@ -60,7 +61,6 @@
pffi-string->pointer pffi-string->pointer
pffi-pointer->string pffi-pointer->string
pffi-struct-make pffi-struct-make
pffi-struct-size
pffi-struct-pointer pffi-struct-pointer
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
@ -81,6 +81,7 @@
(chicken random)) (chicken random))
(export pffi-init (export pffi-init
pffi-size-of pffi-size-of
pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-shared-object-auto-load
pffi-shared-object-load pffi-shared-object-load
@ -94,7 +95,6 @@
pffi-string->pointer pffi-string->pointer
pffi-pointer->string pffi-pointer->string
pffi-struct-make pffi-struct-make
pffi-struct-size
pffi-struct-pointer pffi-struct-pointer
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
@ -111,6 +111,7 @@
(scheme cyclone primitives)) (scheme cyclone primitives))
(export pffi-init (export pffi-init
pffi-size-of pffi-size-of
pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-shared-object-auto-load
pffi-shared-object-load pffi-shared-object-load
@ -124,7 +125,6 @@
pffi-string->pointer pffi-string->pointer
pffi-pointer->string pffi-pointer->string
pffi-struct-make pffi-struct-make
pffi-struct-size
pffi-struct-pointer pffi-struct-pointer
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
@ -142,6 +142,7 @@
(only (gambit) c-declare c-lambda c-define)) (only (gambit) c-declare c-lambda c-define))
(export pffi-init (export pffi-init
pffi-size-of pffi-size-of
pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-shared-object-auto-load
pffi-shared-object-load pffi-shared-object-load
@ -155,7 +156,6 @@
;pffi-string->pointer ;pffi-string->pointer
;pffi-pointer->string ;pffi-pointer->string
pffi-struct-make pffi-struct-make
pffi-struct-size
pffi-struct-pointer pffi-struct-pointer
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
@ -171,6 +171,7 @@
(scheme process-context)) (scheme process-context))
(export pffi-init (export pffi-init
;pffi-size-of ;pffi-size-of
pffi-type?
pffi-align-of pffi-align-of
;pffi-shared-object-auto-load ;pffi-shared-object-auto-load
;pffi-shared-object-load ;pffi-shared-object-load
@ -184,7 +185,6 @@
;pffi-string->pointer ;pffi-string->pointer
;pffi-pointer->string ;pffi-pointer->string
pffi-struct-make pffi-struct-make
pffi-struct-size
pffi-struct-pointer pffi-struct-pointer
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
@ -200,6 +200,7 @@
(scheme process-context)) (scheme process-context))
(export pffi-init (export pffi-init
;pffi-size-of ;pffi-size-of
pffi-type?
;pffi-align-of ;pffi-align-of
;pffi-shared-object-auto-load ;pffi-shared-object-auto-load
;pffi-shared-object-load ;pffi-shared-object-load
@ -213,7 +214,6 @@
;pffi-string->pointer ;pffi-string->pointer
;pffi-pointer->string ;pffi-pointer->string
pffi-struct-make pffi-struct-make
pffi-struct-size
pffi-struct-pointer pffi-struct-pointer
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
@ -232,6 +232,7 @@
(system foreign-library)) (system foreign-library))
(export pffi-init (export pffi-init
pffi-size-of pffi-size-of
pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-shared-object-auto-load
pffi-shared-object-load pffi-shared-object-load
@ -246,7 +247,6 @@
pffi-string->pointer pffi-string->pointer
pffi-pointer->string pffi-pointer->string
pffi-struct-make pffi-struct-make
pffi-struct-size
pffi-struct-pointer pffi-struct-pointer
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
@ -262,6 +262,7 @@
(scheme process-context)) (scheme process-context))
(export pffi-init (export pffi-init
pffi-size-of pffi-size-of
pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-shared-object-auto-load
pffi-shared-object-load pffi-shared-object-load
@ -275,7 +276,6 @@
pffi-string->pointer pffi-string->pointer
pffi-pointer->string pffi-pointer->string
pffi-struct-make pffi-struct-make
pffi-struct-size
pffi-struct-pointer pffi-struct-pointer
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
@ -298,6 +298,7 @@
) )
(export pffi-init (export pffi-init
;pffi-size-of ;pffi-size-of
pffi-type?
;pffi-align-of ;pffi-align-of
;pffi-shared-object-auto-load ;pffi-shared-object-auto-load
;pffi-shared-object-load ;pffi-shared-object-load
@ -311,7 +312,6 @@
;pffi-string->pointer ;pffi-string->pointer
;pffi-pointer->string ;pffi-pointer->string
pffi-struct-make pffi-struct-make
pffi-struct-size
pffi-struct-pointer pffi-struct-pointer
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
@ -328,6 +328,7 @@
(mosh ffi)) (mosh ffi))
(export pffi-init (export pffi-init
pffi-size-of pffi-size-of
pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-shared-object-auto-load
pffi-shared-object-load pffi-shared-object-load
@ -341,7 +342,6 @@
pffi-string->pointer pffi-string->pointer
pffi-pointer->string pffi-pointer->string
pffi-struct-make pffi-struct-make
pffi-struct-size
pffi-struct-pointer pffi-struct-pointer
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
@ -362,6 +362,7 @@
(ffi vector)) (ffi vector))
(export pffi-init (export pffi-init
pffi-size-of pffi-size-of
pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-shared-object-auto-load
pffi-shared-object-load pffi-shared-object-load
@ -376,7 +377,6 @@
pffi-string->pointer pffi-string->pointer
pffi-pointer->string pffi-pointer->string
pffi-struct-make pffi-struct-make
pffi-struct-size
pffi-struct-pointer pffi-struct-pointer
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
@ -394,6 +394,7 @@
(sagittarius)) (sagittarius))
(export pffi-init (export pffi-init
pffi-size-of pffi-size-of
pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-shared-object-auto-load
pffi-shared-object-load pffi-shared-object-load
@ -408,7 +409,6 @@
pffi-string->pointer pffi-string->pointer
pffi-pointer->string pffi-pointer->string
pffi-struct-make pffi-struct-make
pffi-struct-size
pffi-struct-pointer pffi-struct-pointer
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
@ -424,6 +424,7 @@
(scheme process-context)) (scheme process-context))
(export pffi-init (export pffi-init
;pffi-size-of ;pffi-size-of
pffi-type?
;pffi-align-of ;pffi-align-of
;pffi-shared-object-auto-load ;pffi-shared-object-auto-load
;pffi-shared-object-load ;pffi-shared-object-load
@ -437,7 +438,6 @@
;pffi-string->pointer ;pffi-string->pointer
;pffi-pointer->string ;pffi-pointer->string
pffi-struct-make pffi-struct-make
pffi-struct-size
pffi-struct-pointer pffi-struct-pointer
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
@ -454,6 +454,7 @@
(stklos)) (stklos))
(export pffi-init (export pffi-init
pffi-size-of pffi-size-of
pffi-type?
pffi-align-of pffi-align-of
pffi-shared-object-auto-load pffi-shared-object-auto-load
pffi-shared-object-load pffi-shared-object-load
@ -467,7 +468,6 @@
;pffi-string->pointer ;pffi-string->pointer
;pffi-pointer->string ;pffi-pointer->string
pffi-struct-make pffi-struct-make
pffi-struct-size
pffi-struct-pointer pffi-struct-pointer
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
@ -483,6 +483,7 @@
(scheme process-context)) (scheme process-context))
(export pffi-init (export pffi-init
;pffi-size-of ;pffi-size-of
pffi-type?
;pffi-align-of ;pffi-align-of
;pffi-shared-object-auto-load ;pffi-shared-object-auto-load
;pffi-shared-object-load ;pffi-shared-object-load
@ -496,7 +497,6 @@
;pffi-string->pointer ;pffi-string->pointer
;pffi-pointer->string ;pffi-pointer->string
pffi-struct-make pffi-struct-make
pffi-struct-size
pffi-struct-pointer pffi-struct-pointer
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
@ -512,6 +512,7 @@
(scheme process-context)) (scheme process-context))
(export ;pffi-init (export ;pffi-init
;pffi-size-of ;pffi-size-of
pffi-type?
;pffi-align-of ;pffi-align-of
;pffi-shared-object-auto-load ;pffi-shared-object-auto-load
;pffi-shared-object-load ;pffi-shared-object-load
@ -525,7 +526,6 @@
;pffi-string->pointer ;pffi-string->pointer
;pffi-pointer->string ;pffi-pointer->string
pffi-struct-make pffi-struct-make
pffi-struct-size
pffi-struct-pointer pffi-struct-pointer
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
@ -556,6 +556,9 @@
(cond-expand (cond-expand
(stklos (include "retropikzel/r7rs-pffi/struct.scm")) ; FIXME temporarily for stklos 2.10 (stklos (include "retropikzel/r7rs-pffi/struct.scm")) ; FIXME temporarily for stklos 2.10
(else (include "r7rs-pffi/struct.scm"))) (else (include "r7rs-pffi/struct.scm")))
(cond-expand
(stklos (include "retropikzel/r7rs-pffi/union.scm")) ; FIXME temporarily for stklos 2.10
(else (include "r7rs-pffi/union.scm")))
(cond-expand (cond-expand
(stklos (include "retropikzel/r7rs-pffi/main.scm")) ; FIXME temporarily for stklos 2.10 (stklos (include "retropikzel/r7rs-pffi/main.scm")) ; FIXME temporarily for stklos 2.10
(else (include "r7rs-pffi/main.scm")))) (else (include "r7rs-pffi/main.scm"))))

8
retropikzel/r7rs-pffi/chibi.scm
View File

@ -1,4 +1,4 @@
(define pffi-size-of (define size-of-type
(lambda (type) (lambda (type)
(cond ((eq? type 'int8) (size-of-int8_t)) (cond ((eq? type 'int8) (size-of-int8_t))
((eq? type 'uint8) (size-of-uint8_t)) ((eq? type 'uint8) (size-of-uint8_t))
@ -19,7 +19,7 @@
((eq? type 'float) (size-of-float)) ((eq? type 'float) (size-of-float))
((eq? type 'double) (size-of-double)) ((eq? type 'double) (size-of-double))
((eq? type 'pointer) (size-of-pointer)) ((eq? type 'pointer) (size-of-pointer))
(else (error "Can not get size of unknown type" type))))) ((eq? type 'string) (size-of-pointer)))))
(define pffi-shared-object-load (define pffi-shared-object-load
(lambda (headers path . options) (lambda (headers path . options)
@ -163,7 +163,7 @@
value) value)
((procedure? value) ((procedure? value)
(scheme-procedure-to-pointer value)) (scheme-procedure-to-pointer value))
(else (let ((pointer (pffi-pointer-allocate (pffi-size-of type)))) (else (let ((pointer (pffi-pointer-allocate (size-of-type type))))
(pffi-pointer-set! pointer type 0 value) (pffi-pointer-set! pointer type 0 value)
pointer))))) pointer)))))
@ -180,7 +180,7 @@
(return-value (pffi-pointer-allocate (return-value (pffi-pointer-allocate
(if (equal? return-type 'void) (if (equal? return-type 'void)
0 0
(pffi-size-of return-type))))) (size-of-type return-type)))))
(when (not (pffi-pointer-null? maybe-dlerror)) (when (not (pffi-pointer-null? maybe-dlerror))
(error (pffi-pointer->string maybe-dlerror))) (error (pffi-pointer->string maybe-dlerror)))
(lambda arguments (lambda arguments

5
retropikzel/r7rs-pffi/chicken5.scm
View File

@ -117,7 +117,7 @@
(begin ,@ procedure-body)) (begin ,@ procedure-body))
(define ,scheme-name (location external_123456789))))))) (define ,scheme-name (location external_123456789)))))))
(define pffi-size-of (define size-of-type
(lambda (type) (lambda (type)
(cond ((equal? type 'int8) (foreign-value "sizeof(int8_t)" int)) (cond ((equal? type 'int8) (foreign-value "sizeof(int8_t)" int))
((equal? type 'uint8) (foreign-value "sizeof(uint8_t)" int)) ((equal? type 'uint8) (foreign-value "sizeof(uint8_t)" int))
@ -138,7 +138,8 @@
((equal? type 'float) (foreign-value "sizeof(float)" int)) ((equal? type 'float) (foreign-value "sizeof(float)" int))
((equal? type 'double) (foreign-value "sizeof(double)" int)) ((equal? type 'double) (foreign-value "sizeof(double)" int))
((equal? type 'pointer) (foreign-value "sizeof(void*)" int)) ((equal? type 'pointer) (foreign-value "sizeof(void*)" int))
(else (error "pffi-size-of -- No such pffi type" type))))) ((equal? type 'string) (foreign-value "sizeof(void*)" int))
((equal? type 'callback) (foreign-value "sizeof(void*)" int)))))
(define pffi-pointer-allocate (define pffi-pointer-allocate
(lambda (size) (lambda (size)

4
retropikzel/r7rs-pffi/chicken6.scm
View File

@ -113,7 +113,7 @@
(begin ,@ procedure-body)) (begin ,@ procedure-body))
(define ,scheme-name (location external_123456789))))))) (define ,scheme-name (location external_123456789)))))))
(define pffi-size-of (define size-of-type
(lambda (type) (lambda (type)
(cond ((equal? type 'int8) (foreign-value "sizeof(int8_t)" int)) (cond ((equal? type 'int8) (foreign-value "sizeof(int8_t)" int))
((equal? type 'uint8) (foreign-value "sizeof(uint8_t)" int)) ((equal? type 'uint8) (foreign-value "sizeof(uint8_t)" int))
@ -134,7 +134,7 @@
((equal? type 'float) (foreign-value "sizeof(float)" int)) ((equal? type 'float) (foreign-value "sizeof(float)" int))
((equal? type 'double) (foreign-value "sizeof(double)" int)) ((equal? type 'double) (foreign-value "sizeof(double)" int))
((equal? type 'pointer) (foreign-value "sizeof(void*)" int)) ((equal? type 'pointer) (foreign-value "sizeof(void*)" int))
(else (error "pffi-size-of -- No such pffi type" type))))) (else #f)))))
(define pffi-pointer-allocate (define pffi-pointer-allocate
(lambda (size) (lambda (size)

5
retropikzel/r7rs-pffi/cyclone.scm
View File

@ -71,7 +71,7 @@
(lambda (scheme-name return-type argument-types procedure) (lambda (scheme-name return-type argument-types procedure)
(error "pffi-define-callback not yet implemented on Cyclone"))) (error "pffi-define-callback not yet implemented on Cyclone")))
(define pffi-size-of (define size-of-type
(lambda (type) (lambda (type)
(cond ((equal? type 'int8) (c-value "sizeof(int8_t)" int)) (cond ((equal? type 'int8) (c-value "sizeof(int8_t)" int))
((equal? type 'uint8) (c-value "sizeof(uint8_t)" int)) ((equal? type 'uint8) (c-value "sizeof(uint8_t)" int))
@ -91,8 +91,7 @@
((equal? type 'unsigned-long) (c-value "sizeof(unsigned long)" int)) ((equal? type 'unsigned-long) (c-value "sizeof(unsigned long)" int))
((equal? type 'float) (c-value "sizeof(float)" int)) ((equal? type 'float) (c-value "sizeof(float)" int))
((equal? type 'double) (c-value "sizeof(double)" int)) ((equal? type 'double) (c-value "sizeof(double)" int))
((equal? type 'pointer) (c-value "sizeof(void*)" int)) ((equal? type 'pointer) (c-value "sizeof(void*)" int)))))
(else (error "pffi-size-of -- No such pffi type" type)))))
(define-c pffi-pointer-allocate (define-c pffi-pointer-allocate
"(void *data, int argc, closure _, object k, object size)" "(void *data, int argc, closure _, object k, object size)"

2
retropikzel/r7rs-pffi/gambit.scm
View File

@ -26,7 +26,7 @@
(define size-of-void* (c-lambda () int "___return(sizeof(void*));")) (define size-of-void* (c-lambda () int "___return(sizeof(void*));"))
(define pffi-size-of (define size-of-type
(lambda (type) (lambda (type)
(cond ((eq? type 'int8) (size-of-int8_t)) (cond ((eq? type 'int8) (size-of-int8_t))
((eq? type 'uint8) (size-of-uint8_t)) ((eq? type 'uint8) (size-of-uint8_t))

2
retropikzel/r7rs-pffi/gauche.scm
View File

@ -1,3 +1,3 @@
(define pffi-size-of (define size-of-type
(lambda (type) (lambda (type)
(cond ((equal? type 'int8) 1)))) (cond ((equal? type 'int8) 1))))

2
retropikzel/r7rs-pffi/gerbil.scm
View File

@ -11,7 +11,7 @@
((pffi-define scheme-name shared-object c-name return-type argument-types) ((pffi-define scheme-name shared-object c-name return-type argument-types)
(error "Not defined")))) (error "Not defined"))))
(define pffi-size-of (define size-of-type
(lambda (type) (lambda (type)
(error "Not defined"))) (error "Not defined")))

18
retropikzel/r7rs-pffi/guile.scm
View File

@ -45,7 +45,7 @@
procedure procedure
(map pffi-type->native-type argument-types)))))) (map pffi-type->native-type argument-types))))))
(define pffi-size-of (define size-of-type
(lambda (type) (lambda (type)
(sizeof (pffi-type->native-type type)))) (sizeof (pffi-type->native-type type))))
@ -96,14 +96,14 @@
((equal? type 'char) (bytevector-s8-set! p offset (char->integer value))) ((equal? type 'char) (bytevector-s8-set! p offset (char->integer value)))
((equal? type 'short) (bytevector-s8-set! p offset value)) ((equal? type 'short) (bytevector-s8-set! p offset value))
((equal? type 'unsigned-short) (bytevector-u8-set! p offset value)) ((equal? type 'unsigned-short) (bytevector-u8-set! p offset value))
((equal? type 'int) (bytevector-sint-set! p offset value (native-endianness) (pffi-size-of type))) ((equal? type 'int) (bytevector-sint-set! p offset value (native-endianness) (size-of-type type)))
((equal? type 'unsigned-int) (bytevector-uint-set! p offset value (native-endianness) (pffi-size-of type))) ((equal? type 'unsigned-int) (bytevector-uint-set! p offset value (native-endianness) (size-of-type type)))
((equal? type 'long) (bytevector-s64-set! p offset value (native-endianness))) ((equal? type 'long) (bytevector-s64-set! p offset value (native-endianness)))
((equal? type 'unsigned-long) (bytevector-u64-set! p offset value (native-endianness))) ((equal? type 'unsigned-long) (bytevector-u64-set! p offset value (native-endianness)))
((equal? type 'float) (bytevector-ieee-single-set! p offset value (native-endianness))) ((equal? type 'float) (bytevector-ieee-single-set! p offset value (native-endianness)))
((equal? type 'double) (bytevector-ieee-double-set! p offset value (native-endianness))) ((equal? type 'double) (bytevector-ieee-double-set! p offset value (native-endianness)))
((equal? type 'pointer) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (pffi-size-of type))) ((equal? type 'pointer) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (size-of-type type)))
((equal? type 'string) (bytevector-sint-set! p offset (pointer-address (pffi-string->pointer value)) (native-endianness) (pffi-size-of type))))))) ((equal? type 'string) (bytevector-sint-set! p offset (pointer-address (pffi-string->pointer value)) (native-endianness) (size-of-type type)))))))
(define pffi-pointer-get (define pffi-pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
@ -119,14 +119,14 @@
((equal? type 'char) (integer->char (bytevector-s8-ref p offset))) ((equal? type 'char) (integer->char (bytevector-s8-ref p offset)))
((equal? type 'short) (bytevector-s8-ref p offset)) ((equal? type 'short) (bytevector-s8-ref p offset))
((equal? type 'unsigned-short) (bytevector-u8-ref p offset)) ((equal? type 'unsigned-short) (bytevector-u8-ref p offset))
((equal? type 'int) (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type))) ((equal? type 'int) (bytevector-sint-ref p offset (native-endianness) (size-of-type type)))
((equal? type 'unsigned-int) (bytevector-uint-ref p offset (native-endianness) (pffi-size-of type))) ((equal? type 'unsigned-int) (bytevector-uint-ref p offset (native-endianness) (size-of-type type)))
((equal? type 'long) (bytevector-s64-ref p offset (native-endianness))) ((equal? type 'long) (bytevector-s64-ref p offset (native-endianness)))
((equal? type 'unsigned-long) (bytevector-u64-ref p offset (native-endianness))) ((equal? type 'unsigned-long) (bytevector-u64-ref p offset (native-endianness)))
((equal? type 'float) (bytevector-ieee-single-ref p offset (native-endianness))) ((equal? type 'float) (bytevector-ieee-single-ref p offset (native-endianness)))
((equal? type 'double) (bytevector-ieee-double-ref p offset (native-endianness))) ((equal? type 'double) (bytevector-ieee-double-ref p offset (native-endianness)))
((equal? type 'pointer) (make-pointer (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type)))) ((equal? type 'pointer) (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type))))
((equal? type 'string) (pffi-pointer->string (make-pointer (bytevector-sint-ref p offset (native-endianness) (pffi-size-of type))))))))) ((equal? type 'string) (pffi-pointer->string (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type)))))))))
(define pffi-struct-dereference (define pffi-struct-dereference
(lambda (struct) (lambda (struct)

2
retropikzel/r7rs-pffi/kawa.scm
View File

@ -123,7 +123,7 @@
method-handle))) method-handle)))
(invoke native-linker 'upcallStub method-handle function-descriptor arena)))))) (invoke native-linker 'upcallStub method-handle function-descriptor arena))))))
(define pffi-size-of (define size-of-type
(lambda (type) (lambda (type)
(invoke (pffi-type->native-type type) 'byteAlignment))) (invoke (pffi-type->native-type type) 'byteAlignment)))

2
retropikzel/r7rs-pffi/larceny.scm
View File

@ -1,7 +1,7 @@
(require 'std-ffi) (require 'std-ffi)
;; FIXME ;; FIXME
(define pffi-size-of (define size-of-type
(lambda (type) (lambda (type)
(cond ((eq? type 'int8) 1) (cond ((eq? type 'int8) 1)
((eq? type 'uint8) 1) ((eq? type 'uint8) 1)

10
retropikzel/r7rs-pffi/main.scm
View File

@ -7,7 +7,15 @@
(chicken memory)))))) (chicken memory))))))
(else (else
(define pffi-init (define pffi-init
(lambda () (+ 1 1))))) (lambda () #t))))
(define (pffi-type? object) (if (equal? (size-of-type object) #f) #f #t))
(define (pffi-size-of object)
(cond ((pffi-struct? object) (pffi-struct-size object))
((pffi-union? object) (pffi-union-size object))
((pffi-type? object) (size-of-type object))
(else (error "Not pffi-struct, pffi-enum of pffi-type" object))))
(define pffi-types (define pffi-types
'(int8 '(int8

6
retropikzel/r7rs-pffi/mosh.scm
View File

@ -1,4 +1,4 @@
(define pffi-size-of (define size-of-type
(lambda (type) (lambda (type)
(cond ((eq? type 'int8) 1) (cond ((eq? type 'int8) 1)
((eq? type 'uint8) 1) ((eq? type 'uint8) 1)
@ -95,10 +95,10 @@
(index 0)) (index 0))
(string-for-each (string-for-each
(lambda (c) (lambda (c)
(pffi-pointer-set! pointer 'char (* index (pffi-size-of 'char)) c) (pffi-pointer-set! pointer 'char (* index (size-of-type 'char)) c)
(set! index (+ index 1))) (set! index (+ index 1)))
string-content) string-content)
(pffi-pointer-set! pointer 'char (* index (pffi-size-of 'char)) #\null) (pffi-pointer-set! pointer 'char (* index (size-of-type 'char)) #\null)
pointer))) pointer)))
(define pffi-pointer->string (define pffi-pointer->string

2
retropikzel/r7rs-pffi/racket.scm
View File

@ -45,7 +45,7 @@
(mlist->list (map pffi-type->native-type argument-types)) (mlist->list (map pffi-type->native-type argument-types))
(pffi-type->native-type return-type))))))) (pffi-type->native-type return-type)))))))
(define pffi-size-of (define size-of-type
(lambda (type) (lambda (type)
(ctype-sizeof (pffi-type->native-type type)))) (ctype-sizeof (pffi-type->native-type type))))

5
retropikzel/r7rs-pffi/sagittarius.scm
View File

@ -47,7 +47,7 @@
(map pffi-type->native-type argument-types) (map pffi-type->native-type argument-types)
procedure))))) procedure)))))
(define pffi-size-of (define size-of-type
(lambda (type) (lambda (type)
(cond ((eq? type 'int8) size-of-int8_t) (cond ((eq? type 'int8) size-of-int8_t)
((eq? type 'uint8) size-of-uint8_t) ((eq? type 'uint8) size-of-uint8_t)
@ -68,7 +68,8 @@
((eq? type 'float) size-of-float) ((eq? type 'float) size-of-float)
((eq? type 'double) size-of-double) ((eq? type 'double) size-of-double)
((eq? type 'pointer) size-of-void*) ((eq? type 'pointer) size-of-void*)
(else (error "Can not get size of unknown type" type))))) ((eq? type 'string) size-of-void*)
(else #f))))
(define pffi-pointer-allocate (define pffi-pointer-allocate
(lambda (size) (lambda (size)

2
retropikzel/r7rs-pffi/skint.scm
View File

@ -1,3 +1,3 @@
(define pffi-size-of (define size-of-type
(lambda (type) (lambda (type)
(cond ((equal? type 'int8) 1)))) (cond ((equal? type 'int8) 1))))

2
retropikzel/r7rs-pffi/stklos.scm
View File

@ -43,7 +43,7 @@
(error "Not implemented"))) (error "Not implemented")))
; If youre reading this, this is just a temp hack. Dont judge me :D ; If youre reading this, this is just a temp hack. Dont judge me :D
(define pffi-size-of (define size-of-type
(lambda (type) (lambda (type)
(cond (cond
((equal? type 'int8) 1) ((equal? type 'int8) 1)

6
retropikzel/r7rs-pffi/struct.scm
View File

@ -11,7 +11,7 @@
(lambda (type) (lambda (type)
(cond-expand (cond-expand
;(guile (alignof (pffi-type->native-type type))) ;(guile (alignof (pffi-type->native-type type)))
(else (pffi-size-of type))))) (else (size-of-type type)))))
(define (round-to-next-modulo-of to-round roundee) (define (round-to-next-modulo-of to-round roundee)
(if (= (floor-remainder to-round roundee) 0) (if (= (floor-remainder to-round roundee) 0)
@ -25,8 +25,8 @@
(let* ((name (cdr member)) (let* ((name (cdr member))
(type (car member)) (type (car member))
(type-alignment (pffi-align-of type))) (type-alignment (pffi-align-of type)))
(when (> (pffi-size-of type) largest-member-size) (when (> (size-of-type type) largest-member-size)
(set! largest-member-size (pffi-size-of type))) (set! largest-member-size (size-of-type type)))
(if (or (= size 0) (if (or (= size 0)
(= (floor-remainder size type-alignment) 0)) (= (floor-remainder size type-alignment) 0))
(begin (begin

2
retropikzel/r7rs-pffi/tr7.scm
View File

@ -1,3 +1,3 @@
(define pffi-size-of (define size-of-type
(lambda (type) (lambda (type)
(cond ((equal? type 'int8) 1)))) (cond ((equal? type 'int8) 1))))

8
retropikzel/r7rs-pffi/union.scm Normal file
View File

@ -0,0 +1,8 @@
(define-record-type <pffi-union>
(union-make c-type size pointer members)
pffi-union?
(c-type pffi-union-c-type)
(size pffi-union-size)
(pointer pffi-union-pointer)
(members pffi-union-members))

75
test.scm
View File

@ -58,6 +58,57 @@
(pffi-init) (pffi-init)
;; pffi-type?
(print-header 'pffi-type?)
(debug (pffi-type? 'int8))
(assert equal? (pffi-type? 'int8) #t)
(debug (pffi-type? 'uint8))
(assert equal? (pffi-type? 'uint8) #t)
(debug (pffi-type? 'int16))
(assert equal? (pffi-type? 'int16) #t)
(debug (pffi-type? 'uint16))
(assert equal? (pffi-type? 'uint16) #t)
(debug (pffi-type? 'int32))
(assert equal? (pffi-type? 'int32) #t)
(debug (pffi-type? 'uint32))
(assert equal? (pffi-type? 'uint32) #t)
(debug (pffi-type? 'int64))
(assert equal? (pffi-type? 'int64) #t)
(debug (pffi-type? 'uint64))
(assert equal? (pffi-type? 'uint64) #t)
(debug (pffi-type? 'char))
(assert equal? (pffi-type? 'char) #t)
(debug (pffi-type? 'unsigned-char))
(assert equal? (pffi-type? 'unsigned-char) #t)
(debug (pffi-type? 'short))
(assert equal? (pffi-type? 'short) #t)
(debug (pffi-type? 'unsigned-short))
(assert equal? (pffi-type? 'unsigned-short) #t)
(debug (pffi-type? 'int))
(assert equal? (pffi-type? 'int) #t)
(debug (pffi-type? 'unsigned-int))
(assert equal? (pffi-type? 'unsigned-int) #t)
(debug (pffi-type? 'long))
(assert equal? (pffi-type? 'long) #t)
(debug (pffi-type? 'unsigned-long))
(assert equal? (pffi-type? 'unsigned-long) #t)
(debug (pffi-type? 'float))
(assert equal? (pffi-type? 'float) #t)
(debug (pffi-type? 'double))
(assert equal? (pffi-type? 'double) #t)
(debug (pffi-type? 'string))
(assert equal? (pffi-type? 'string) #t)
(debug (pffi-type? 'pointer))
(assert equal? (pffi-type? 'pointer) #t)
(debug (pffi-type? 'void))
(assert equal? (pffi-type? 'void) #t)
(debug (pffi-type? 'callback))
(assert equal? (pffi-type? 'callback) #t)
(pffi-init)
;; pffi-size-of ;; pffi-size-of
(print-header 'pffi-size-of) (print-header 'pffi-size-of)
@ -449,28 +500,28 @@
(define struct1 (pffi-struct-make 'test '((int . r) (int . g) (int . b)))) (define struct1 (pffi-struct-make 'test '((int . r) (int . g) (int . b))))
(debug struct1) (debug struct1)
(debug (pffi-struct-size struct1)) (debug (pffi-size-of struct1))
(assert = (pffi-struct-size struct1) 12) (assert = (pffi-size-of struct1) 12)
(define struct2 (pffi-struct-make 'test '((int8 . r) (int8 . g) (int . b)))) (define struct2 (pffi-struct-make 'test '((int8 . r) (int8 . g) (int . b))))
(debug struct2) (debug struct2)
(debug (pffi-struct-size struct2)) (debug (pffi-size-of struct2))
(assert = (pffi-struct-size struct2) 8) (assert = (pffi-size-of struct2) 8)
(define struct3 (pffi-struct-make 'test '((int8 . r) (int8 . g) (int . b)))) (define struct3 (pffi-struct-make 'test '((int8 . r) (int8 . g) (int . b))))
(debug struct3) (debug struct3)
(debug (pffi-struct-size struct3)) (debug (pffi-size-of struct3))
(assert = (pffi-struct-size struct3) 8) (assert = (pffi-size-of struct3) 8)
(define struct4 (pffi-struct-make 'test '((int8 . r) (pointer . a) (int8 . g) (int . b)))) (define struct4 (pffi-struct-make 'test '((int8 . r) (pointer . a) (int8 . g) (int . b))))
(debug struct4) (debug struct4)
(debug (pffi-struct-size struct4)) (debug (pffi-size-of struct4))
(assert = (pffi-struct-size struct4) 24) (assert = (pffi-size-of struct4) 24)
(define struct5 (pffi-struct-make 'test '((int8 . r) (char . b) (pointer . a) (int8 . g) (int . b)))) (define struct5 (pffi-struct-make 'test '((int8 . r) (char . b) (pointer . a) (int8 . g) (int . b))))
(debug struct5) (debug struct5)
(debug (pffi-struct-size struct5)) (debug (pffi-size-of struct5))
(assert = (pffi-struct-size struct5) 24) (assert = (pffi-size-of struct5) 24)
(define struct6 (pffi-struct-make 'test '((int8 . a) (define struct6 (pffi-struct-make 'test '((int8 . a)
(char . b) (char . b)
@ -487,8 +538,8 @@
(double . m) (double . m)
(float . n)))) (float . n))))
(debug struct6) (debug struct6)
(debug (pffi-struct-size struct6)) (debug (pffi-size-of struct6))
(assert = (pffi-struct-size struct6) 96) (assert = (pffi-size-of struct6) 96)
;; pffi-string->pointer ;; pffi-string->pointer