diff --git a/Makefile b/Makefile index 0224db9..36d1614 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,5 @@ CC=gcc +DOCKER=docker run -it -v ${PWD}:/workdir CHIBI=chibi-scheme -A . test-chibi-podman-amd64: @@ -10,7 +11,13 @@ retropikzel/r7rs-pffi/r7rs-pffi-chibi.c: chibi-ffi retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub retropikzel/r7rs-pffi/r7rs-pffi-chibi.so: retropikzel/r7rs-pffi/r7rs-pffi-chibi.c - ${CC} -o retropikzel/r7rs-pffi/r7rs-pffi-chibi.so -fPIC -shared retropikzel/r7rs-pffi/r7rs-pffi-chibi.c -lchibi-scheme -lffi + ${CC} -o retropikzel/r7rs-pffi/r7rs-pffi-chibi.so \ + -fPIC \ + -shared retropikzel/r7rs-pffi/r7rs-pffi-chibi.c \ + -lchibi-scheme \ + -lffi \ + -L${HOME}/.scman/chibi/lib \ + -I${HOME}/.scman/chibi/include test-chibi: retropikzel/r7rs-pffi/r7rs-pffi-chibi.so ${CHIBI} test.scm @@ -87,9 +94,9 @@ test-kawa-podman-amd64: test-kawa: ${KAWA} test.scm -LARCENY=larceny -r7 -I . -test-larceny-podman-amd64: - podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/larceny:latest bash -c "cd /workdir && ${LARCENY} test.scm" +LARCENY=larceny -r7 -I . +test-larceny-docker: + ${DOCKER} schemers/larceny:latest bash -c "cd /workdir && ${LARCENY} test.scm" test-larceny: ${LARCENY} test.scm diff --git a/retropikzel/r7rs-pffi.sld b/retropikzel/r7rs-pffi.sld index fd9ba03..675f84f 100644 --- a/retropikzel/r7rs-pffi.sld +++ b/retropikzel/r7rs-pffi.sld @@ -11,6 +11,7 @@ (chibi)) (export pffi-init pffi-size-of + pffi-align-of pffi-shared-object-auto-load pffi-shared-object-load pffi-pointer-null @@ -22,6 +23,9 @@ pffi-pointer-get pffi-string->pointer pffi-pointer->string + pffi-struct-allocate + pffi-struct-size + pffi-struct-pointer pffi-define ;pffi-define-callback ;pffi-pointer-address @@ -41,6 +45,7 @@ (chicken random)) (export pffi-init pffi-size-of + pffi-align-of pffi-shared-object-auto-load pffi-shared-object-load pffi-pointer-null @@ -52,6 +57,9 @@ pffi-pointer-get pffi-string->pointer pffi-pointer->string + pffi-struct-allocate + pffi-struct-size + pffi-struct-pointer pffi-define pffi-define-callback pffi-pointer-address @@ -67,6 +75,7 @@ (scheme cyclone primitives)) (export pffi-init pffi-size-of + pffi-align-of pffi-shared-object-auto-load pffi-shared-object-load pffi-pointer-null @@ -78,6 +87,9 @@ pffi-pointer-get pffi-string->pointer pffi-pointer->string + pffi-struct-allocate + pffi-struct-size + pffi-struct-pointer pffi-define ;pffi-define-callback ;pffi-pointer-address @@ -92,6 +104,7 @@ (only (gambit) c-declare c-lambda c-define)) (export pffi-init pffi-size-of + pffi-align-of pffi-shared-object-auto-load pffi-shared-object-load ;pffi-pointer-null @@ -103,6 +116,9 @@ ;pffi-pointer-get ;pffi-string->pointer ;pffi-pointer->string + pffi-struct-allocate + pffi-struct-size + pffi-struct-pointer ;pffi-define ;pffi-define-callback ;pffi-pointer-address @@ -116,6 +132,7 @@ (scheme process-context)) (export pffi-init ;pffi-size-of + pffi-align-of ;pffi-shared-object-auto-load ;pffi-shared-object-load ;pffi-pointer-null @@ -127,6 +144,9 @@ ;pffi-pointer-get ;pffi-string->pointer ;pffi-pointer->string + pffi-struct-allocate + pffi-struct-size + pffi-struct-pointer ;pffi-define ;pffi-define-callback ;pffi-pointer-address @@ -140,6 +160,7 @@ (scheme process-context)) (export pffi-init ;pffi-size-of + ;pffi-align-of ;pffi-shared-object-auto-load ;pffi-shared-object-load ;pffi-pointer-null @@ -151,6 +172,9 @@ ;pffi-pointer-get ;pffi-string->pointer ;pffi-pointer->string + pffi-struct-allocate + pffi-struct-size + pffi-struct-pointer ;pffi-define ;pffi-define-callback ;pffi-pointer-address @@ -167,6 +191,7 @@ (system foreign-library)) (export pffi-init pffi-size-of + pffi-align-of pffi-shared-object-auto-load pffi-shared-object-load pffi-pointer-null @@ -178,6 +203,9 @@ pffi-pointer-get pffi-string->pointer pffi-pointer->string + pffi-struct-allocate + pffi-struct-size + pffi-struct-pointer pffi-define pffi-define-callback pffi-pointer-address @@ -190,6 +218,7 @@ (scheme process-context)) (export pffi-init pffi-size-of + pffi-align-of pffi-shared-object-auto-load pffi-shared-object-load pffi-pointer-null @@ -201,6 +230,9 @@ pffi-pointer-get pffi-string->pointer pffi-pointer->string + pffi-struct-allocate + pffi-struct-size + pffi-struct-pointer pffi-define ;pffi-define-callback ;pffi-pointer-address @@ -219,6 +251,7 @@ ) (export pffi-init ;pffi-size-of + ;pffi-align-of ;pffi-shared-object-auto-load ;pffi-shared-object-load ;pffi-pointer-null @@ -230,6 +263,9 @@ ;pffi-pointer-get ;pffi-string->pointer ;pffi-pointer->string + pffi-struct-allocate + pffi-struct-size + pffi-struct-pointer ;pffi-define ;pffi-define-callback ;pffi-pointer-address @@ -245,6 +281,7 @@ (mosh ffi)) (export pffi-init pffi-size-of + pffi-align-of pffi-shared-object-auto-load pffi-shared-object-load pffi-pointer-null @@ -256,6 +293,9 @@ pffi-pointer-get pffi-string->pointer pffi-pointer->string + pffi-struct-allocate + pffi-struct-size + pffi-struct-pointer pffi-define pffi-define-callback ;pffi-pointer-address @@ -274,6 +314,7 @@ (ffi vector)) (export pffi-init pffi-size-of + pffi-align-of pffi-shared-object-auto-load pffi-shared-object-load pffi-pointer-null @@ -285,6 +326,9 @@ pffi-pointer-get pffi-string->pointer pffi-pointer->string + pffi-struct-allocate + pffi-struct-size + pffi-struct-pointer pffi-define pffi-define-callback pffi-pointer-address @@ -299,6 +343,7 @@ (sagittarius)) (export pffi-init pffi-size-of + pffi-align-of pffi-shared-object-auto-load pffi-shared-object-load pffi-pointer-null @@ -310,6 +355,9 @@ pffi-pointer-get pffi-string->pointer pffi-pointer->string + pffi-struct-allocate + pffi-struct-size + pffi-struct-pointer pffi-define pffi-define-callback pffi-pointer-address @@ -322,6 +370,7 @@ (scheme process-context)) (export pffi-init ;pffi-size-of + ;pffi-align-of ;pffi-shared-object-auto-load ;pffi-shared-object-load ;pffi-pointer-null @@ -333,6 +382,9 @@ ;pffi-pointer-get ;pffi-string->pointer ;pffi-pointer->string + pffi-struct-allocate + pffi-struct-size + pffi-struct-pointer ;pffi-define ;pffi-define-callback ;pffi-pointer-address @@ -347,6 +399,7 @@ (stklos)) (export pffi-init pffi-size-of + pffi-align-of pffi-shared-object-auto-load pffi-shared-object-load pffi-pointer-null @@ -354,10 +407,13 @@ pffi-pointer-allocate pffi-pointer? pffi-pointer-free - ;pffi-pointer-set! + pffi-pointer-set! ;pffi-pointer-get ;pffi-string->pointer ;pffi-pointer->string + pffi-struct-allocate + pffi-struct-size + pffi-struct-pointer ;pffi-define ;pffi-define-callback ;pffi-pointer-address @@ -371,6 +427,7 @@ (scheme process-context)) (export pffi-init ;pffi-size-of + ;pffi-align-of ;pffi-shared-object-auto-load ;pffi-shared-object-load ;pffi-pointer-null @@ -382,6 +439,9 @@ ;pffi-pointer-get ;pffi-string->pointer ;pffi-pointer->string + pffi-struct-allocate + pffi-struct-size + pffi-struct-pointer ;pffi-define ;pffi-define-callback ;pffi-pointer-address @@ -394,24 +454,29 @@ (scheme file) (scheme process-context)) (export ;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? - ;pffi-pointer-free - ;pffi-pointer-set! - ;pffi-pointer-get - ;pffi-string->pointer - ;pffi-pointer->string - ;pffi-define - ;pffi-define-callback - ;pffi-pointer-address - ;pffi-pointer-dereference + ;pffi-size-of + ;pffi-align-of + ;pffi-shared-object-auto-load + ;pffi-shared-object-load + ;pffi-pointer-null + ;pffi-pointer-null? + ;pffi-pointer-allocate + ;pffi-pointer? + ;pffi-pointer-free + ;pffi-pointer-set! + ;pffi-pointer-get + ;pffi-string->pointer + ;pffi-pointer->string + pffi-struct-allocate + pffi-struct-size + pffi-struct-pointer + ;pffi-define + ;pffi-define-callback + ;pffi-pointer-address + ;pffi-pointer-dereference )) (else (error "Unsupported implementation"))) + (include "r7rs-pffi/struct.scm") (cond-expand (chibi (include "r7rs-pffi/chibi.scm")) (chicken (include "r7rs-pffi/chicken.scm")) @@ -430,6 +495,4 @@ (tr7 (include "r7rs-pffi/tr7.scm")) (ypsilon (include "r7rs-pffi/ypsilon.scm")) (else #t)) - (cond-expand - (stklos (include "retropikzel/r7rs-pffi/main.scm")) - (else (include "r7rs-pffi/main.scm")))) + (include "r7rs-pffi/main.scm")) diff --git a/retropikzel/r7rs-pffi/stklos.scm b/retropikzel/r7rs-pffi/stklos.scm index 4b55178..52dc66c 100644 --- a/retropikzel/r7rs-pffi/stklos.scm +++ b/retropikzel/r7rs-pffi/stklos.scm @@ -107,14 +107,7 @@ (lambda (pointer type offset value) (let ((null-pointer (pffi-pointer-null)) (offset-address (cpointer-data pointer))) - (cpointer-data-set! null-pointer offset-address) - (display "HERE") - (newline) - (write null-pointer) - (newline) - (exit) - ;(error "Not implemented") - ))) + (cpointer-data-set! null-pointer offset-address)))) (define pffi-pointer-get (lambda (pointer type offset) diff --git a/retropikzel/r7rs-pffi/struct.scm b/retropikzel/r7rs-pffi/struct.scm new file mode 100644 index 0000000..8e91fd7 --- /dev/null +++ b/retropikzel/r7rs-pffi/struct.scm @@ -0,0 +1,43 @@ +(define-record-type + (pffi-struct-make name size pointer members) + pffi-struct? + (name pffi-struct-name) + (size pffi-struct-size) + (pointer pffi-struct-pointer) + (members pffi-struct-members)) + +(define pffi-align-of + (lambda (type) + (cond-expand + (guile (alignof (pffi-type->native-type type))) + (else (pffi-size-of type))))) + +(define (round-to-next-modulo-of to-round roundee) + (if (= (floor-remainder to-round roundee) 0) + to-round + (round-to-next-modulo-of (+ to-round 1) roundee))) + +(define (calculate-struct-size types) + (cond-expand + (guile (sizeof (map pffi-type->native-type types))) + (else + (let ((size 0)) + (for-each + (lambda (type) + (let ((type-alignment (pffi-align-of type))) + (if (or (= size 0) + (= (floor-remainder size type-alignment) 0)) + (set! size (+ size type-alignment)) + (set! size (+ (round-to-next-modulo-of size type-alignment) type-alignment))))) + types) + size)))) + +(define pffi-word-size + (cond-expand + (larceny 4) ; 32-bit system + (else 8))) ; 64-bit system + +(define (pffi-struct-allocate name members) + (let* ((size (calculate-struct-size (map car members))) + (pointer (pffi-pointer-allocate size))) + (pffi-struct-make name size pointer members))) diff --git a/test.scm b/test.scm index 331c6af..b6cd4ef 100644 --- a/test.scm +++ b/test.scm @@ -191,6 +191,144 @@ (assert equal? (number? size-pointer) #t) (assert = size-pointer 8))) +;; pffi-align-of + +(print-header 'pffi-align-of) + +(define align-int8 (pffi-align-of 'int8)) +(debug align-int8) +(assert equal? (number? align-int8) #t) +(assert = align-int8 1) + +(define align-uint8 (pffi-align-of 'uint8)) +(debug align-uint8) +(assert equal? (number? align-uint8) #t) +(assert = align-uint8 1) + +(assert equal? (number? (pffi-align-of 'uint8)) #t) +(define align-int16 (pffi-align-of 'int16)) +(debug align-int16) +(assert equal? (number? align-int16) #t) +(assert = align-int16 2) + +(assert equal? (number? (pffi-align-of 'int16)) #t) +(define align-uint16 (pffi-align-of 'uint16)) +(debug align-uint16) +(assert equal? (number? align-uint16) #t) +(assert = align-uint16 2) + +(assert equal? (number? (pffi-align-of 'uint16)) #t) +(define align-int32 (pffi-align-of 'int32)) +(debug align-int32) +(assert equal? (number? align-int32) #t) +(assert = align-int32 4) + +(assert equal? (number? (pffi-align-of 'int32)) #t) +(define align-uint32 (pffi-align-of 'uint32)) +(debug align-uint32) +(assert equal? (number? align-uint32) #t) +(assert = align-uint32 4) + +(assert equal? (number? (pffi-align-of 'uint32)) #t) +(define align-int64 (pffi-align-of 'int64)) +(debug align-int64) +(assert equal? (number? align-int64) #t) +(assert = align-int64 8) + +(assert equal? (number? (pffi-align-of 'int64)) #t) +(define align-uint64 (pffi-align-of 'uint64)) +(debug align-uint64) +(assert equal? (number? align-uint64) #t) +(assert = align-uint64 8) + +(assert equal? (number? (pffi-align-of 'uint64)) #t) +(define align-char (pffi-align-of 'char)) +(debug align-char) +(assert equal? (number? align-char) #t) +(assert = align-char 1) + +(assert equal? (number? (pffi-align-of 'char)) #t) +(define align-unsigned-char (pffi-align-of 'unsigned-char)) +(debug align-unsigned-char) +(assert equal? (number? align-unsigned-char) #t) +(assert = align-unsigned-char 1) + +(assert equal? (number? (pffi-align-of 'unsigned-char)) #t) +(define align-short (pffi-align-of 'short)) +(debug align-short) +(assert equal? (number? align-short) #t) +(assert = align-short 2) + +(assert equal? (number? (pffi-align-of 'short)) #t) +(define align-unsigned-short (pffi-align-of 'unsigned-short)) +(debug align-unsigned-short) +(assert equal? (number? align-unsigned-short) #t) +(assert = align-unsigned-short 2) + +(assert equal? (number? (pffi-align-of 'unsigned-short)) #t) +(define align-int (pffi-align-of 'int)) +(debug align-int) +(assert equal? (number? align-int) #t) +(assert = align-int 4) + +(assert equal? (number? (pffi-align-of 'int)) #t) +(define align-unsigned-int (pffi-align-of 'unsigned-int)) +(debug align-unsigned-int) +(assert equal? (number? align-unsigned-int) #t) +(assert = align-unsigned-int 4) + +(cond-expand + (larceny ;; Works on 32 bit mode + (assert equal? (number? (pffi-align-of 'long)) #t) + (define align-long (pffi-align-of 'long)) + (debug align-long) + (assert equal? (number? align-long) #t) + (assert = align-long 4)) + (else + (assert equal? (number? (pffi-align-of 'long)) #t) + (define align-long (pffi-align-of 'long)) + (debug align-long) + (assert equal? (number? align-long) #t) + (assert = align-long 8))) + +(cond-expand + (larceny ;; Works on 32 bit mode + (assert equal? (number? (pffi-align-of 'unsigned-long)) #t) + (define align-unsigned-long (pffi-align-of 'unsigned-long)) + (debug align-unsigned-long) + (assert equal? (number? align-unsigned-long) #t) + (assert = align-unsigned-long 4)) + (else + (assert equal? (number? (pffi-align-of 'long)) #t) + (define align-unsigned-long (pffi-align-of 'unsigned-long)) + (debug align-unsigned-long) + (assert equal? (number? align-unsigned-long) #t) + (assert = align-unsigned-long 8))) + +(assert equal? (number? (pffi-align-of 'float)) #t) +(define align-float (pffi-align-of 'float)) +(debug align-float) +(assert equal? (number? align-float) #t) +(assert = align-float 4) + +(assert equal? (number? (pffi-align-of 'double)) #t) +(define align-double (pffi-align-of 'double)) +(debug align-double) +(assert equal? (number? align-double) #t) +(assert = align-double 8) + +(cond-expand + (larceny ;; Works on 32 bit mode + (define align-pointer (pffi-align-of 'pointer)) + (debug align-pointer) + (assert equal? (number? align-pointer) #t) + (assert = align-pointer 4)) + (else + (define align-pointer (pffi-align-of 'pointer)) + (debug align-pointer) + (assert equal? (number? align-pointer) #t) + (assert = align-pointer 8))) + ;; pffi-shared-object-auto-load (print-header 'pffi-shared-object-auto-load) @@ -202,7 +340,6 @@ (debug libc-stdlib) -#| ;; pffi-pointer-null (print-header 'pffi-pointer-null) @@ -294,6 +431,24 @@ (debug (pffi-pointer-get set-pointer 'double offset)) (assert = (pffi-pointer-get set-pointer 'double offset) 1.5) +; pffi-struct-allocate + +(define struct1 (pffi-struct-allocate 'test '((int . r) (int . g) (int . b)))) +(debug struct1) +(debug (pffi-struct-size struct1)) +(assert = (pffi-struct-size struct1) 12) + +(define struct2 (pffi-struct-allocate 'test '((int8 . r) (int8 . g) (int . b)))) +(debug struct2) +(debug (pffi-struct-size struct2)) +(assert = (pffi-struct-size struct2) 8) + +(define struct3 (pffi-struct-allocate 'test '((int8 . r) (int8 . g) (int . b)))) +(debug struct3) +(debug (pffi-struct-size struct3)) +(assert = (pffi-struct-size struct3) 8) + +#| ;; pffi-string->pointer (print-header 'pffi-string->pointer)