From 7b12ab40cbfd51f4568918601089d2278da03e8f Mon Sep 17 00:00:00 2001 From: retropikzel Date: Mon, 17 Feb 2025 20:03:55 +0200 Subject: [PATCH] Make pffi-size-of work with structs too --- README.md | 51 ++++++++---------- manifest.scm | 6 ++- retropikzel/r7rs-pffi.sld | 37 +++++++------ retropikzel/r7rs-pffi/chibi.scm | 8 +-- retropikzel/r7rs-pffi/chicken5.scm | 5 +- retropikzel/r7rs-pffi/chicken6.scm | 4 +- retropikzel/r7rs-pffi/cyclone.scm | 5 +- retropikzel/r7rs-pffi/gambit.scm | 2 +- retropikzel/r7rs-pffi/gauche.scm | 2 +- retropikzel/r7rs-pffi/gerbil.scm | 2 +- retropikzel/r7rs-pffi/guile.scm | 18 +++---- retropikzel/r7rs-pffi/kawa.scm | 2 +- retropikzel/r7rs-pffi/larceny.scm | 2 +- retropikzel/r7rs-pffi/main.scm | 10 +++- retropikzel/r7rs-pffi/mosh.scm | 6 +-- retropikzel/r7rs-pffi/racket.scm | 2 +- retropikzel/r7rs-pffi/sagittarius.scm | 5 +- retropikzel/r7rs-pffi/skint.scm | 2 +- retropikzel/r7rs-pffi/stklos.scm | 2 +- retropikzel/r7rs-pffi/struct.scm | 6 +-- retropikzel/r7rs-pffi/tr7.scm | 2 +- retropikzel/r7rs-pffi/union.scm | 8 +++ test.scm | 75 ++++++++++++++++++++++----- 23 files changed, 164 insertions(+), 98 deletions(-) create mode 100644 retropikzel/r7rs-pffi/union.scm diff --git a/README.md b/README.md index fb04292..6719d9d 100644 --- a/README.md +++ b/README.md @@ -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-pointer->string](#strongpffi-pointer-gtstringstrong-pointer--gt-string) - [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-offset-get](#strongpffi-struct-offset-getstrong-member-name--gt-number) - [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 -| | 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 | -|--------------|-----------|--------------|------------------------------|-------------------------|-------------------|--------------------|-----------------------|----------------------|---------------|-------------------|-------------------|------------------|----------------------|----------------------|------------------|------------------|---------------------|------------------------|-----------------|------------------|-------------------------|-------------|----------------------| -| Guile | 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 | X | -| Saggittarius | X | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | +| | 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 | +| 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 | ### 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 | -|--------------|-----------|--------------|------------------------------|-------------------------|-------------------|--------------------|-----------------------|----------------------|---------------|-------------------|-------------------|------------------|----------------------|----------------------|------------------|------------------|---------------------|------------------------|-----------------|------------------|-------------------------|-------------|----------------------| -| Chibi | 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 | X | -| Cyclone | X | 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 | | | | -| Gauche | X | | | | | | | | | | | | | | X | X | X | X | X | X | | | | -| Gerbil | X | | | | | | | | | | | | | | X | X | X | X | X | X | | | | -| Larceny | 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 | X | -| Skint | X | | | | | | | | | | | | | | X | X | X | X | X | X | | | | -| Stklos | X | X | X | X | X | X | X | | X | X | | | | | X | X | X | X | X | X | | | | -| tr7 | | | | | | | | | | | | | | | X | X | X | X | X | X | | | | -| Ypsilon | | | | | | | | | | | | | | | X | X | X | X | X | X | | | | +| | 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 | | +| 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 | | +| Gambit | X | X | | | | | | | | | | | | | X | X | X | X | X | | | | +| Gauche | X | | | | | | | | | | | | | | X | X | X | X | X | | | | +| Gerbil | 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 | +| Skint | 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 | | | | +| Ypsilon | | | | | | | | | | | | | | | X | X | X | X | X | | | | ### 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 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 @@ -294,14 +293,6 @@ names and types. For example: 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 Returns the pointer that holds the struct content. You need to use this when passing a struct as diff --git a/manifest.scm b/manifest.scm index bb90bc1..0f11ff8 100644 --- a/manifest.scm +++ b/manifest.scm @@ -2,4 +2,8 @@ ;; You can store it in a file that you may then pass to any 'guix' command ;; that accepts a '--manifest' (or '-m') option. -(specifications->manifest (list "gcc-toolchain")) +(specifications->manifest (list "gcc-toolchain" + "guile-next" + "racket" + "chicken" + "stklos")) diff --git a/retropikzel/r7rs-pffi.sld b/retropikzel/r7rs-pffi.sld index 1877191..eb43617 100644 --- a/retropikzel/r7rs-pffi.sld +++ b/retropikzel/r7rs-pffi.sld @@ -11,6 +11,7 @@ (chibi)) (export pffi-init pffi-size-of + pffi-type? pffi-align-of pffi-shared-object-auto-load pffi-shared-object-load @@ -24,7 +25,6 @@ pffi-string->pointer pffi-pointer->string pffi-struct-make - pffi-struct-size pffi-struct-pointer pffi-struct-offset-get pffi-struct-get @@ -46,6 +46,7 @@ (chicken random)) (export pffi-init pffi-size-of + pffi-type? pffi-align-of pffi-shared-object-auto-load pffi-shared-object-load @@ -60,7 +61,6 @@ pffi-string->pointer pffi-pointer->string pffi-struct-make - pffi-struct-size pffi-struct-pointer pffi-struct-offset-get pffi-struct-get @@ -81,6 +81,7 @@ (chicken random)) (export pffi-init pffi-size-of + pffi-type? pffi-align-of pffi-shared-object-auto-load pffi-shared-object-load @@ -94,7 +95,6 @@ pffi-string->pointer pffi-pointer->string pffi-struct-make - pffi-struct-size pffi-struct-pointer pffi-struct-offset-get pffi-struct-get @@ -111,6 +111,7 @@ (scheme cyclone primitives)) (export pffi-init pffi-size-of + pffi-type? pffi-align-of pffi-shared-object-auto-load pffi-shared-object-load @@ -124,7 +125,6 @@ pffi-string->pointer pffi-pointer->string pffi-struct-make - pffi-struct-size pffi-struct-pointer pffi-struct-offset-get pffi-struct-get @@ -142,6 +142,7 @@ (only (gambit) c-declare c-lambda c-define)) (export pffi-init pffi-size-of + pffi-type? pffi-align-of pffi-shared-object-auto-load pffi-shared-object-load @@ -155,7 +156,6 @@ ;pffi-string->pointer ;pffi-pointer->string pffi-struct-make - pffi-struct-size pffi-struct-pointer pffi-struct-offset-get pffi-struct-get @@ -171,6 +171,7 @@ (scheme process-context)) (export pffi-init ;pffi-size-of + pffi-type? pffi-align-of ;pffi-shared-object-auto-load ;pffi-shared-object-load @@ -184,7 +185,6 @@ ;pffi-string->pointer ;pffi-pointer->string pffi-struct-make - pffi-struct-size pffi-struct-pointer pffi-struct-offset-get pffi-struct-get @@ -200,6 +200,7 @@ (scheme process-context)) (export pffi-init ;pffi-size-of + pffi-type? ;pffi-align-of ;pffi-shared-object-auto-load ;pffi-shared-object-load @@ -213,7 +214,6 @@ ;pffi-string->pointer ;pffi-pointer->string pffi-struct-make - pffi-struct-size pffi-struct-pointer pffi-struct-offset-get pffi-struct-get @@ -232,6 +232,7 @@ (system foreign-library)) (export pffi-init pffi-size-of + pffi-type? pffi-align-of pffi-shared-object-auto-load pffi-shared-object-load @@ -246,7 +247,6 @@ pffi-string->pointer pffi-pointer->string pffi-struct-make - pffi-struct-size pffi-struct-pointer pffi-struct-offset-get pffi-struct-get @@ -262,6 +262,7 @@ (scheme process-context)) (export pffi-init pffi-size-of + pffi-type? pffi-align-of pffi-shared-object-auto-load pffi-shared-object-load @@ -275,7 +276,6 @@ pffi-string->pointer pffi-pointer->string pffi-struct-make - pffi-struct-size pffi-struct-pointer pffi-struct-offset-get pffi-struct-get @@ -298,6 +298,7 @@ ) (export pffi-init ;pffi-size-of + pffi-type? ;pffi-align-of ;pffi-shared-object-auto-load ;pffi-shared-object-load @@ -311,7 +312,6 @@ ;pffi-string->pointer ;pffi-pointer->string pffi-struct-make - pffi-struct-size pffi-struct-pointer pffi-struct-offset-get pffi-struct-get @@ -328,6 +328,7 @@ (mosh ffi)) (export pffi-init pffi-size-of + pffi-type? pffi-align-of pffi-shared-object-auto-load pffi-shared-object-load @@ -341,7 +342,6 @@ pffi-string->pointer pffi-pointer->string pffi-struct-make - pffi-struct-size pffi-struct-pointer pffi-struct-offset-get pffi-struct-get @@ -362,6 +362,7 @@ (ffi vector)) (export pffi-init pffi-size-of + pffi-type? pffi-align-of pffi-shared-object-auto-load pffi-shared-object-load @@ -376,7 +377,6 @@ pffi-string->pointer pffi-pointer->string pffi-struct-make - pffi-struct-size pffi-struct-pointer pffi-struct-offset-get pffi-struct-get @@ -394,6 +394,7 @@ (sagittarius)) (export pffi-init pffi-size-of + pffi-type? pffi-align-of pffi-shared-object-auto-load pffi-shared-object-load @@ -408,7 +409,6 @@ pffi-string->pointer pffi-pointer->string pffi-struct-make - pffi-struct-size pffi-struct-pointer pffi-struct-offset-get pffi-struct-get @@ -424,6 +424,7 @@ (scheme process-context)) (export pffi-init ;pffi-size-of + pffi-type? ;pffi-align-of ;pffi-shared-object-auto-load ;pffi-shared-object-load @@ -437,7 +438,6 @@ ;pffi-string->pointer ;pffi-pointer->string pffi-struct-make - pffi-struct-size pffi-struct-pointer pffi-struct-offset-get pffi-struct-get @@ -454,6 +454,7 @@ (stklos)) (export pffi-init pffi-size-of + pffi-type? pffi-align-of pffi-shared-object-auto-load pffi-shared-object-load @@ -467,7 +468,6 @@ ;pffi-string->pointer ;pffi-pointer->string pffi-struct-make - pffi-struct-size pffi-struct-pointer pffi-struct-offset-get pffi-struct-get @@ -483,6 +483,7 @@ (scheme process-context)) (export pffi-init ;pffi-size-of + pffi-type? ;pffi-align-of ;pffi-shared-object-auto-load ;pffi-shared-object-load @@ -496,7 +497,6 @@ ;pffi-string->pointer ;pffi-pointer->string pffi-struct-make - pffi-struct-size pffi-struct-pointer pffi-struct-offset-get pffi-struct-get @@ -512,6 +512,7 @@ (scheme process-context)) (export ;pffi-init ;pffi-size-of + pffi-type? ;pffi-align-of ;pffi-shared-object-auto-load ;pffi-shared-object-load @@ -525,7 +526,6 @@ ;pffi-string->pointer ;pffi-pointer->string pffi-struct-make - pffi-struct-size pffi-struct-pointer pffi-struct-offset-get pffi-struct-get @@ -556,6 +556,9 @@ (cond-expand (stklos (include "retropikzel/r7rs-pffi/struct.scm")) ; FIXME temporarily for stklos 2.10 (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 (stklos (include "retropikzel/r7rs-pffi/main.scm")) ; FIXME temporarily for stklos 2.10 (else (include "r7rs-pffi/main.scm")))) diff --git a/retropikzel/r7rs-pffi/chibi.scm b/retropikzel/r7rs-pffi/chibi.scm index aef33b3..0a07841 100644 --- a/retropikzel/r7rs-pffi/chibi.scm +++ b/retropikzel/r7rs-pffi/chibi.scm @@ -1,4 +1,4 @@ -(define pffi-size-of +(define size-of-type (lambda (type) (cond ((eq? type 'int8) (size-of-int8_t)) ((eq? type 'uint8) (size-of-uint8_t)) @@ -19,7 +19,7 @@ ((eq? type 'float) (size-of-float)) ((eq? type 'double) (size-of-double)) ((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 (lambda (headers path . options) @@ -163,7 +163,7 @@ value) ((procedure? 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) pointer))))) @@ -180,7 +180,7 @@ (return-value (pffi-pointer-allocate (if (equal? return-type 'void) 0 - (pffi-size-of return-type))))) + (size-of-type return-type))))) (when (not (pffi-pointer-null? maybe-dlerror)) (error (pffi-pointer->string maybe-dlerror))) (lambda arguments diff --git a/retropikzel/r7rs-pffi/chicken5.scm b/retropikzel/r7rs-pffi/chicken5.scm index 586c522..fc4b7d2 100644 --- a/retropikzel/r7rs-pffi/chicken5.scm +++ b/retropikzel/r7rs-pffi/chicken5.scm @@ -117,7 +117,7 @@ (begin ,@ procedure-body)) (define ,scheme-name (location external_123456789))))))) -(define pffi-size-of +(define size-of-type (lambda (type) (cond ((equal? type 'int8) (foreign-value "sizeof(int8_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 'double) (foreign-value "sizeof(double)" 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 (lambda (size) diff --git a/retropikzel/r7rs-pffi/chicken6.scm b/retropikzel/r7rs-pffi/chicken6.scm index ddd7922..b5ec6fc 100644 --- a/retropikzel/r7rs-pffi/chicken6.scm +++ b/retropikzel/r7rs-pffi/chicken6.scm @@ -113,7 +113,7 @@ (begin ,@ procedure-body)) (define ,scheme-name (location external_123456789))))))) -(define pffi-size-of +(define size-of-type (lambda (type) (cond ((equal? type 'int8) (foreign-value "sizeof(int8_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 'double) (foreign-value "sizeof(double)" 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 (lambda (size) diff --git a/retropikzel/r7rs-pffi/cyclone.scm b/retropikzel/r7rs-pffi/cyclone.scm index b5e770d..f2063f8 100644 --- a/retropikzel/r7rs-pffi/cyclone.scm +++ b/retropikzel/r7rs-pffi/cyclone.scm @@ -71,7 +71,7 @@ (lambda (scheme-name return-type argument-types procedure) (error "pffi-define-callback not yet implemented on Cyclone"))) -(define pffi-size-of +(define size-of-type (lambda (type) (cond ((equal? type 'int8) (c-value "sizeof(int8_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 'float) (c-value "sizeof(float)" int)) ((equal? type 'double) (c-value "sizeof(double)" int)) - ((equal? type 'pointer) (c-value "sizeof(void*)" int)) - (else (error "pffi-size-of -- No such pffi type" type))))) + ((equal? type 'pointer) (c-value "sizeof(void*)" int))))) (define-c pffi-pointer-allocate "(void *data, int argc, closure _, object k, object size)" diff --git a/retropikzel/r7rs-pffi/gambit.scm b/retropikzel/r7rs-pffi/gambit.scm index c04bff7..bd16fbd 100644 --- a/retropikzel/r7rs-pffi/gambit.scm +++ b/retropikzel/r7rs-pffi/gambit.scm @@ -26,7 +26,7 @@ (define size-of-void* (c-lambda () int "___return(sizeof(void*));")) -(define pffi-size-of +(define size-of-type (lambda (type) (cond ((eq? type 'int8) (size-of-int8_t)) ((eq? type 'uint8) (size-of-uint8_t)) diff --git a/retropikzel/r7rs-pffi/gauche.scm b/retropikzel/r7rs-pffi/gauche.scm index 5c6f2f9..88f9efc 100644 --- a/retropikzel/r7rs-pffi/gauche.scm +++ b/retropikzel/r7rs-pffi/gauche.scm @@ -1,3 +1,3 @@ -(define pffi-size-of +(define size-of-type (lambda (type) (cond ((equal? type 'int8) 1)))) diff --git a/retropikzel/r7rs-pffi/gerbil.scm b/retropikzel/r7rs-pffi/gerbil.scm index 09afe5f..4c32e13 100644 --- a/retropikzel/r7rs-pffi/gerbil.scm +++ b/retropikzel/r7rs-pffi/gerbil.scm @@ -11,7 +11,7 @@ ((pffi-define scheme-name shared-object c-name return-type argument-types) (error "Not defined")))) -(define pffi-size-of +(define size-of-type (lambda (type) (error "Not defined"))) diff --git a/retropikzel/r7rs-pffi/guile.scm b/retropikzel/r7rs-pffi/guile.scm index 6d1f7fa..e28436e 100644 --- a/retropikzel/r7rs-pffi/guile.scm +++ b/retropikzel/r7rs-pffi/guile.scm @@ -45,7 +45,7 @@ procedure (map pffi-type->native-type argument-types)))))) -(define pffi-size-of +(define size-of-type (lambda (type) (sizeof (pffi-type->native-type type)))) @@ -96,14 +96,14 @@ ((equal? type 'char) (bytevector-s8-set! p offset (char->integer value))) ((equal? type 'short) (bytevector-s8-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 'unsigned-int) (bytevector-uint-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) (size-of-type type))) ((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 'float) (bytevector-ieee-single-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 'string) (bytevector-sint-set! p offset (pointer-address (pffi-string->pointer 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) (size-of-type type))))))) (define pffi-pointer-get (lambda (pointer type offset) @@ -119,14 +119,14 @@ ((equal? type 'char) (integer->char (bytevector-s8-ref p offset))) ((equal? type 'short) (bytevector-s8-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 'unsigned-int) (bytevector-uint-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) (size-of-type type))) ((equal? type 'long) (bytevector-s64-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 '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 'string) (pffi-pointer->string (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) (size-of-type type))))))))) (define pffi-struct-dereference (lambda (struct) diff --git a/retropikzel/r7rs-pffi/kawa.scm b/retropikzel/r7rs-pffi/kawa.scm index f422cd1..5d3ccc8 100644 --- a/retropikzel/r7rs-pffi/kawa.scm +++ b/retropikzel/r7rs-pffi/kawa.scm @@ -123,7 +123,7 @@ method-handle))) (invoke native-linker 'upcallStub method-handle function-descriptor arena)))))) -(define pffi-size-of +(define size-of-type (lambda (type) (invoke (pffi-type->native-type type) 'byteAlignment))) diff --git a/retropikzel/r7rs-pffi/larceny.scm b/retropikzel/r7rs-pffi/larceny.scm index 5a53815..c1cb090 100644 --- a/retropikzel/r7rs-pffi/larceny.scm +++ b/retropikzel/r7rs-pffi/larceny.scm @@ -1,7 +1,7 @@ (require 'std-ffi) ;; FIXME -(define pffi-size-of +(define size-of-type (lambda (type) (cond ((eq? type 'int8) 1) ((eq? type 'uint8) 1) diff --git a/retropikzel/r7rs-pffi/main.scm b/retropikzel/r7rs-pffi/main.scm index 2bce69b..94de096 100644 --- a/retropikzel/r7rs-pffi/main.scm +++ b/retropikzel/r7rs-pffi/main.scm @@ -7,7 +7,15 @@ (chicken memory)))))) (else (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 '(int8 diff --git a/retropikzel/r7rs-pffi/mosh.scm b/retropikzel/r7rs-pffi/mosh.scm index 7e47a60..b5fb334 100644 --- a/retropikzel/r7rs-pffi/mosh.scm +++ b/retropikzel/r7rs-pffi/mosh.scm @@ -1,4 +1,4 @@ -(define pffi-size-of +(define size-of-type (lambda (type) (cond ((eq? type 'int8) 1) ((eq? type 'uint8) 1) @@ -95,10 +95,10 @@ (index 0)) (string-for-each (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))) 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))) (define pffi-pointer->string diff --git a/retropikzel/r7rs-pffi/racket.scm b/retropikzel/r7rs-pffi/racket.scm index 7f73a6e..d665122 100644 --- a/retropikzel/r7rs-pffi/racket.scm +++ b/retropikzel/r7rs-pffi/racket.scm @@ -45,7 +45,7 @@ (mlist->list (map pffi-type->native-type argument-types)) (pffi-type->native-type return-type))))))) -(define pffi-size-of +(define size-of-type (lambda (type) (ctype-sizeof (pffi-type->native-type type)))) diff --git a/retropikzel/r7rs-pffi/sagittarius.scm b/retropikzel/r7rs-pffi/sagittarius.scm index 41c0395..c1bf715 100644 --- a/retropikzel/r7rs-pffi/sagittarius.scm +++ b/retropikzel/r7rs-pffi/sagittarius.scm @@ -47,7 +47,7 @@ (map pffi-type->native-type argument-types) procedure))))) -(define pffi-size-of +(define size-of-type (lambda (type) (cond ((eq? type 'int8) size-of-int8_t) ((eq? type 'uint8) size-of-uint8_t) @@ -68,7 +68,8 @@ ((eq? type 'float) size-of-float) ((eq? type 'double) size-of-double) ((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 (lambda (size) diff --git a/retropikzel/r7rs-pffi/skint.scm b/retropikzel/r7rs-pffi/skint.scm index 5c6f2f9..88f9efc 100644 --- a/retropikzel/r7rs-pffi/skint.scm +++ b/retropikzel/r7rs-pffi/skint.scm @@ -1,3 +1,3 @@ -(define pffi-size-of +(define size-of-type (lambda (type) (cond ((equal? type 'int8) 1)))) diff --git a/retropikzel/r7rs-pffi/stklos.scm b/retropikzel/r7rs-pffi/stklos.scm index 1126fb6..590a019 100644 --- a/retropikzel/r7rs-pffi/stklos.scm +++ b/retropikzel/r7rs-pffi/stklos.scm @@ -43,7 +43,7 @@ (error "Not implemented"))) ; If youre reading this, this is just a temp hack. Dont judge me :D -(define pffi-size-of +(define size-of-type (lambda (type) (cond ((equal? type 'int8) 1) diff --git a/retropikzel/r7rs-pffi/struct.scm b/retropikzel/r7rs-pffi/struct.scm index 96725b5..f702c3f 100644 --- a/retropikzel/r7rs-pffi/struct.scm +++ b/retropikzel/r7rs-pffi/struct.scm @@ -11,7 +11,7 @@ (lambda (type) (cond-expand ;(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) (if (= (floor-remainder to-round roundee) 0) @@ -25,8 +25,8 @@ (let* ((name (cdr member)) (type (car member)) (type-alignment (pffi-align-of type))) - (when (> (pffi-size-of type) largest-member-size) - (set! largest-member-size (pffi-size-of type))) + (when (> (size-of-type type) largest-member-size) + (set! largest-member-size (size-of-type type))) (if (or (= size 0) (= (floor-remainder size type-alignment) 0)) (begin diff --git a/retropikzel/r7rs-pffi/tr7.scm b/retropikzel/r7rs-pffi/tr7.scm index 5c6f2f9..88f9efc 100644 --- a/retropikzel/r7rs-pffi/tr7.scm +++ b/retropikzel/r7rs-pffi/tr7.scm @@ -1,3 +1,3 @@ -(define pffi-size-of +(define size-of-type (lambda (type) (cond ((equal? type 'int8) 1)))) diff --git a/retropikzel/r7rs-pffi/union.scm b/retropikzel/r7rs-pffi/union.scm new file mode 100644 index 0000000..93527f3 --- /dev/null +++ b/retropikzel/r7rs-pffi/union.scm @@ -0,0 +1,8 @@ + +(define-record-type + (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)) diff --git a/test.scm b/test.scm index a350438..669e5e9 100755 --- a/test.scm +++ b/test.scm @@ -58,6 +58,57 @@ (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 (print-header 'pffi-size-of) @@ -449,28 +500,28 @@ (define struct1 (pffi-struct-make 'test '((int . r) (int . g) (int . b)))) (debug struct1) -(debug (pffi-struct-size struct1)) -(assert = (pffi-struct-size struct1) 12) +(debug (pffi-size-of struct1)) +(assert = (pffi-size-of struct1) 12) (define struct2 (pffi-struct-make 'test '((int8 . r) (int8 . g) (int . b)))) (debug struct2) -(debug (pffi-struct-size struct2)) -(assert = (pffi-struct-size struct2) 8) +(debug (pffi-size-of struct2)) +(assert = (pffi-size-of struct2) 8) (define struct3 (pffi-struct-make 'test '((int8 . r) (int8 . g) (int . b)))) (debug struct3) -(debug (pffi-struct-size struct3)) -(assert = (pffi-struct-size struct3) 8) +(debug (pffi-size-of struct3)) +(assert = (pffi-size-of struct3) 8) (define struct4 (pffi-struct-make 'test '((int8 . r) (pointer . a) (int8 . g) (int . b)))) (debug struct4) -(debug (pffi-struct-size struct4)) -(assert = (pffi-struct-size struct4) 24) +(debug (pffi-size-of struct4)) +(assert = (pffi-size-of struct4) 24) (define struct5 (pffi-struct-make 'test '((int8 . r) (char . b) (pointer . a) (int8 . g) (int . b)))) (debug struct5) -(debug (pffi-struct-size struct5)) -(assert = (pffi-struct-size struct5) 24) +(debug (pffi-size-of struct5)) +(assert = (pffi-size-of struct5) 24) (define struct6 (pffi-struct-make 'test '((int8 . a) (char . b) @@ -487,8 +538,8 @@ (double . m) (float . n)))) (debug struct6) -(debug (pffi-struct-size struct6)) -(assert = (pffi-struct-size struct6) 96) +(debug (pffi-size-of struct6)) +(assert = (pffi-size-of struct6) 96) ;; pffi-string->pointer