diff --git a/' b/' new file mode 100644 index 0000000..d3d4b11 --- /dev/null +++ b/' @@ -0,0 +1,213 @@ +(define size-of-type + (lambda (type) + (cond ((eq? type 'int8) (size-of-int8_t)) + ((eq? type 'uint8) (size-of-uint8_t)) + ((eq? type 'int16) (size-of-int16_t)) + ((eq? type 'uint16) (size-of-uint16_t)) + ((eq? type 'int32) (size-of-int32_t)) + ((eq? type 'uint32) (size-of-uint32_t)) + ((eq? type 'int64) (size-of-int64_t)) + ((eq? type 'uint64) (size-of-uint64_t)) + ((eq? type 'char) (size-of-char)) + ((eq? type 'unsigned-char) (size-of-char)) + ((eq? type 'short) (size-of-short)) + ((eq? type 'unsigned-short) (size-of-unsigned-short)) + ((eq? type 'int) (size-of-int)) + ((eq? type 'unsigned-int) (size-of-unsigned-int)) + ((eq? type 'long) (size-of-long)) + ((eq? type 'unsigned-long) (size-of-unsigned-long)) + ((eq? type 'float) (size-of-float)) + ((eq? type 'double) (size-of-double)) + ((eq? type 'pointer) (size-of-pointer)) + ((eq? type 'string) (size-of-pointer)) + ((eq? type 'struct) (size-of-pointer)) + ((eq? type 'callback) (size-of-pointer)) + ((eq? type 'void) 0) + (else #f)))) + +(define pffi-shared-object-load + (lambda (path options) + (let ((shared-object (dlopen path RTLD-NOW)) + (maybe-error (dlerror))) + (when (not (pffi-pointer-null? maybe-error)) + (error (pffi-pointer->string maybe-error))) + shared-object))) + +#;(define pffi-pointer-null + (lambda () + (pointer-null))) + +#;(define pffi-pointer-null? + (lambda (pointer) + (not pointer))) ; #f is null on Chibi + +(define pffi-pointer? + (lambda (object) + (or (equal? object #f) ; False can be null pointer + (pointer? object)))) + +(define pffi-pointer-allocate + (lambda (size) + (pointer-allocate size))) + +(define pffi-pointer-address + (lambda (pointer) + (pointer-address pointer))) + +(define pffi-pointer-free + (lambda (pointer) + (pointer-free pointer))) + +(define pffi-pointer-set! + (lambda (pointer type offset value) + (cond ((equal? type 'int8) (pointer-set-c-int8_t! pointer offset value)) + ((equal? type 'uint8) (pointer-set-c-uint8_t! pointer offset value)) + ((equal? type 'int16) (pointer-set-c-int16_t! pointer offset value)) + ((equal? type 'uint16) (pointer-set-c-uint16_t! pointer offset value)) + ((equal? type 'int32) (pointer-set-c-int32_t! pointer offset value)) + ((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value)) + ((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value)) + ((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value)) + ((equal? type 'char) (pointer-set-c-char! pointer offset (char->integer value))) + ((equal? type 'short) (pointer-set-c-short! pointer offset value)) + ((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value)) + ((equal? type 'int) (pointer-set-c-int! pointer offset value)) + ((equal? type 'unsigned-int) (pointer-set-c-unsigned-int! pointer offset value)) + ((equal? type 'long) (pointer-set-c-long! pointer offset value)) + ((equal? type 'unsigned-long) (pointer-set-c-unsigned-long! pointer offset value)) + ((equal? type 'float) (pointer-set-c-float! pointer offset value)) + ((equal? type 'double) (pointer-set-c-double! pointer offset value)) + ((equal? type 'void) (pointer-set-c-pointer! pointer offset value)) + ((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value))))) + +(define pffi-pointer-get + (lambda (pointer type offset) + (cond ((equal? type 'int8) (pointer-ref-c-int8_t pointer offset)) + ((equal? type 'uint8) (pointer-ref-c-uint8_t pointer offset)) + ((equal? type 'int16) (pointer-ref-c-int16_t pointer offset)) + ((equal? type 'uint16) (pointer-ref-c-uint16_t pointer offset)) + ((equal? type 'int32) (pointer-ref-c-int32_t pointer offset)) + ((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset)) + ((equal? type 'int64) (pointer-ref-c-int64_t pointer offset)) + ((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset)) + ((equal? type 'char) (integer->char (pointer-ref-c-char pointer offset))) + ((equal? type 'short) (pointer-ref-c-short pointer offset)) + ((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset)) + ((equal? type 'int) (pointer-ref-c-int pointer offset)) + ((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset)) + ((equal? type 'long) (pointer-ref-c-long pointer offset)) + ((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset)) + ((equal? type 'float) (pointer-ref-c-float pointer offset)) + ((equal? type 'double) (pointer-ref-c-double pointer offset)) + ((equal? type 'void) (pointer-ref-c-pointer pointer offset)) + ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset))))) + +#;(define pffi-string->pointer + (lambda (string-content) + (string-to-pointer string-content))) + +#;(define pffi-pointer->string + (lambda (pointer) + (pointer-to-string pointer))) + +(define pffi-type->native-type + (lambda (type) + (cond ((equal? type 'int8) 'int8_t) + ((equal? type 'uint8) 'uint8_t) + ((equal? type 'int16) 'int16_t) + ((equal? type 'uint16) 'uint16_t) + ((equal? type 'int32) 'int32_t) + ((equal? type 'uint32) 'uint32_t) + ((equal? type 'int64) 'int64_t) + ((equal? type 'uint64) 'uint64_t) + ((equal? type 'char) 'char) + ((equal? type 'unsigned-char) 'char) + ((equal? type 'short) 'short) + ((equal? type 'unsigned-short) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'unsigned-int) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'unsigned-long) 'unsigned-long) + ((equal? type 'float) 'float) + ((equal? type 'double) 'double) + ((equal? type 'pointer) '(maybe-null void*)) + ((equal? type 'string) 'string) + ((equal? type 'void) 'void) + ((equal? type 'callback) '(maybe-null void*)) + (else (error "pffi-type->native-type -- No such pffi type" type))))) + +;; pffi-define-function + +(define pffi-type->libffi-type + (lambda (type) + (cond ((equal? type 'int8) (get-ffi-type-int8)) + ((equal? type 'uint8) (get-ffi-type-uint8)) + ((equal? type 'int16) (get-ffi-type-int16)) + ((equal? type 'uint16) (get-ffi-type-uint16)) + ((equal? type 'int32) (get-ffi-type-int32)) + ((equal? type 'uint32) (get-ffi-type-uint32)) + ((equal? type 'int64) (get-ffi-type-int64)) + ((equal? type 'uint64) (get-ffi-type-uint64)) + ((equal? type 'char) (get-ffi-type-char)) + ((equal? type 'unsigned-char) (get-ffi-type-uchar)) + ((equal? type 'bool) (get-ffi-type-int8)) + ((equal? type 'short) (get-ffi-type-short)) + ((equal? type 'unsigned-short) (get-ffi-type-ushort)) + ((equal? type 'int) (get-ffi-type-int)) + ((equal? type 'unsigned-int) (get-ffi-type-uint)) + ((equal? type 'long) (get-ffi-type-long)) + ((equal? type 'unsigned-long) (get-ffi-type-ulong)) + ((equal? type 'float) (get-ffi-type-float)) + ((equal? type 'double) (get-ffi-type-double)) + ((equal? type 'void) (get-ffi-type-void)) + ((equal? type 'pointer) (get-ffi-type-pointer)) + ((equal? type 'callback) (get-ffi-type-pointer))))) + +(define argument->pointer + (lambda (value type) + (cond ((procedure? value) (scheme-procedure-to-pointer value)) + (else (let ((pointer (pffi-pointer-allocate (size-of-type type)))) + (pffi-pointer-set! pointer type 0 value) + pointer))))) + +(define make-c-function + (lambda (shared-object c-name return-type argument-types) + (dlerror) ;; Clean all previous errors + (let ((c-function (dlsym shared-object c-name)) + (maybe-dlerror (dlerror))) + (when (not (pffi-pointer-null? maybe-dlerror)) + (error (pffi-pointer->string maybe-dlerror))) + (lambda arguments + (let ((return-value (pffi-pointer-allocate + (if (equal? return-type 'void) + 0 + (size-of-type return-type))))) + (internal-ffi-call (length argument-types) + (pffi-type->libffi-type return-type) + (map pffi-type->libffi-type argument-types) + c-function + return-value + (map argument->pointer + arguments + argument-types)) + (cond ((not (equal? return-type 'void)) + (pffi-pointer-get return-value return-type 0)))))))) + +(define-syntax pffi-define-function + (syntax-rules () + ((_ scheme-name shared-object c-name return-type argument-types) + (define scheme-name + (make-c-function shared-object + (symbol->string c-name) + return-type + argument-types))))) + +(define make-c-callback + (lambda (return-type argument-types procedure) + (scheme-procedure-to-pointer procedure))) + +(define-syntax pffi-define-callback + (syntax-rules () + ((_ scheme-name return-type argument-types procedure) + (define scheme-name + (make-c-callback return-type 'argument-types procedure))))) diff --git a/.gitignore b/.gitignore index f17fed8..ad79d61 100644 --- a/.gitignore +++ b/.gitignore @@ -44,3 +44,4 @@ tests/retropikzel *.rkt testfile.test tests/testfile.test +snow diff --git a/Makefile b/Makefile index b34c1ba..20c8ba1 100644 --- a/Makefile +++ b/Makefile @@ -4,6 +4,9 @@ DOCKER=docker run -it -v ${PWD}:/workdir DOCKER_INIT=cd /workdir && make clean && VERSION=$(shell grep "version:" README.md | awk '{split\($0,a\); print a[2];}') +snow: + snow-chibi --install-source-dir ./snow install "(r6rs bytevectors)" + # apt-get install pandoc weasyprint docs: mkdir -p documentation @@ -64,13 +67,19 @@ tr7: ypsilon: make -C retropikzel/pffi tr7 -test-compile-r7rs: tmp/test/libtest.o tmp/test/libtest.so +test-compile-r7rs: tmp/test/libtest.o tmp/test/libtest.so tmp/test/libtest.a make ${COMPILE_R7RS} cp -r retropikzel tmp/test/ cp tests/compliance.scm tmp/test/ cp tests/c-include/libtest.h tmp/test/ - cd tmp/test && COMPILE_R7RS_CHICKEN="-L -ltest -I. -L." compile-r7rs -I . -o compliance compliance.scm - cd tmp/test && LD_LIBRARY_PATH=. ./compliance + cp -r snow/* tmp/test/ + cd tmp/test && \ + COMPILE_R7RS_GAMBIT="-cc-options \"-ltest -I. -L\" -ld-options \"-L.\"" \ + COMPILE_R7RS_CHICKEN="-L -ltest -I. -L." \ + compile-r7rs -I . -o compliance compliance.scm + cd tmp/test && \ + LD_LIBRARY_PATH=. \ + ./compliance test-compile-r7rs-docker: docker build --build-arg COMPILE_R7RS=${COMPILE_R7RS} --tag=r7rs-pffi-test-${COMPILE_R7RS} -f dockerfiles/test . @@ -84,10 +93,11 @@ tmp/test/libtest.so: tests/c-src/libtest.c mkdir -p tmp/test ${CC} -o tmp/test/libtest.so -shared -fPIC tests/c-src/libtest.c -I./include -tmp/test/libtest.a: tmp/test/libtest.o src/libtest.c +tmp/test/libtest.a: tmp/test/libtest.o tests/c-src/libtest.c ar rcs tmp/test/libtest.a tmp/test/libtest.o clean: + @rm -rf retropikzel/pffi/pffi.c @rm -rf retropikzel/pffi/*.o* @rm -rf retropikzel/pffi/*.so @rm -rf retropikzel/pffi/*.meta diff --git a/README.md b/README.md index 4739cb8..15aadb4 100644 --- a/README.md +++ b/README.md @@ -47,19 +47,19 @@ conforming to some specification. - [PFFI\_LOAD\_PATH](#environment-variables-pffi-load-path) - [Procedures and macros](#procedures-and-macros) - [pffi-init](#pffi-init) - - [pffi-size-of](#pffi-size-of) + - [c-size-of](#c-size-of) - [pffi-align-of](#pffi-align-of) - - [pffi-define-library](#pffi-define-library) - - [pffi-pointer-null](#pffi-pointer-null) - - [pffi-pointer-null?](#pffi-pointer-null) - - [pffi-pointer-allocate](#pffi-pointer-allocate) + - [define-c-library](#define-c-library) + - [make-c-null](#make-c-null) + - [c-null?](#is-c-null) + - [make-c-bytevector ](#make-c-bytevector ) - [pffi-pointer-address](#pffi-pointer-address) - - [pffi-pointer?](#pffi-pointer) - - [pffi-pointer-free](#pffi-pointer-free) + - [c-bytevector?](#is-c-bytevector) + - [c-free](#c-free) - [pffi-pointer-set!](#pffi-pointer-set!) - [pffi-pointer-get](#pffi-pointer-get) - - [pffi-string->pointer](#pffi-string->pointer) - - [pffi-pointer->string](#pffi-pointer->string) + - [string->c-bytevector](#string-into-c-bytevector) + - [c-bytevector->sring](#c-bytevector-into-string) - [pffi-struct-make](#pffi-struct-make) - [pffi-struct-pointer](#pffi-struct-pointer) - [pffi-struct-offset-get](#pffi-struct-offset-get) @@ -73,7 +73,7 @@ conforming to some specification. - [pffi-array-set!](#pffi-array-set!) - [pffi-list->array](#pffi-list->array) - [pffi-array->list](#pffi-array->list) - - [pffi-define-function](#pffi-define-function) + - [define-c-procedure](#define-c-procedure) - [pffi-define-callback](#pffi-define-callback) @@ -99,8 +99,7 @@ conforming to some specification. ## Status -Currently the interface of the library is in okay shape. It propably will not change much but no -guarantees are being made just yet. +In alpha. ### Current caveats @@ -111,7 +110,7 @@ guarantees are being made just yet. - Always pass pffi-define-callback procedure as lambda in place - No support for variadic function arguments - Can be partially worked around by defining multiple versions of same - function with different amount of arguments + function with different number of arguments ## Roadmap @@ -123,24 +122,24 @@ For roadmap to 1.0.0 see [issues](https://todo.sr.ht/~retropikzel/r7rs-pffi?sear ## Primitives -| | pffi-init | pffi-size-of | pffi-define-library | pffi-pointer-null | pffi-pointer-null? | pffi-pointer-address | pffi-pointer? | pffi-pointer-set! | pffi-pointer-get | pffi-define | pffi-define-callback | -|--------------|:---------:|:------------:|:-------------------:|:-----------------:|:------------------:|:--------------------:|:-------------:|:-----------------:|:----------------:|:-----------:|:--------------------:| -| Chibi | X | X | X | X | X | X | X | X | X | X | | -| Chicken | X | X | X | X | X | X | X | X | X | X | X | -| Cyclone | X | X | X | X | X | | X | X | X | X | | -| Gambit | X | X | | | | X | | | | | | -| Gauche | X | X | X | X | X | X | X | X | X | X | | -| Gerbil | X | | | | | | | | | | | -| Guile | X | X | X | X | X | X | X | X | X | X | X | -| Kawa | X | X | X | X | X | X | X | X | X | X | X | -| Larceny | X | | | | | | | | | | | -| Mosh | X | X | X | X | X | | X | X | X | X | X | -| Racket | X | X | X | X | X | X | X | X | X | X | X | -| Saggittarius | X | X | X | X | X | X | X | X | X | X | X | -| Skint | X | | | | | | | | | | | -| Stklos | X | X | X | X | X | | X | | | | | -| tr7 | | | | | | | | | | | | -| Ypsilon | X | X | X | X | X | X | X | X | X | X | X | +| | c-size-of | define-c-library | c-bytevector? | pffi-pointer-set! | pffi-pointer-get | define-c-procedure | pffi-define-callback | +|--------------|:------------:|:-------------------:|:-------------:|:-----------------:|:----------------:|:-------------------:|:--------------------:| +| Chibi | X | X | X | X | X | X | | +| Chicken | X | X | X | X | X | X | X | +| Cyclone | X | X | X | X | X | X | | +| Gambit | X | | | | | | | +| Gauche | X | X | X | X | X | X | | +| Gerbil | | | | | | | | +| Guile | X | X | X | X | X | X | X | +| Kawa | X | X | X | X | X | X | X | +| Larceny | | | | | | | | +| Mosh | X | X | X | X | X | X | X | +| Racket | X | X | X | X | X | X | X | +| Saggittarius | X | X | X | X | X | X | X | +| Skint | | | | | | | | +| Stklos | X | X | X | | | | | +| tr7 | | | | | | | | +| Ypsilon | X | X | X | X | X | X | X | ## Built upon @@ -148,8 +147,11 @@ For roadmap to 1.0.0 see [issues](https://todo.sr.ht/~retropikzel/r7rs-pffi?sear These features are built upon the primitives and if primitives are implemented and work, they should work too. -- pffi-pointer-allocate -- pffi-pointer-free +- make-c-bytevector +- make-c-null +- c-null? +- pffi-pointer-address +- c-free - pffi-pointer-\>string - pffi-string-\>pointer - pffi-struct-make @@ -339,10 +341,10 @@ 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 - +#### c-size-of + -**pffi-size-of** object -> number +**c-size-of** object -> number Returns the size of the pffi-struct, pffi-enum or pffi-type. @@ -353,10 +355,10 @@ Returns the size of the pffi-struct, pffi-enum or pffi-type. Returns the align of the type. -#### pffi-define-library - +#### define-c-library + -**pffi-define-library** headers shared-object-name [options] -> object +**define-c-library** headers shared-object-name [options] -> object Load given shared object automatically searching many predefined paths. @@ -377,12 +379,12 @@ keyword. The options are: Example: (cond-expand - (windows (pffi-define-library libc-stdlib + (windows (define-c-library libc-stdlib '("stdlib.h") "ucrtbase" '((additional-versions ("0" "6")) (additiona-paths ("."))))) - (else (pffi-define-library libc-stdlib + (else (define-c-library libc-stdlib (list "stdlib.h") "c" '((additional-versions ("0" "6")) @@ -399,45 +401,57 @@ implementations. - Do pass the options using quote - As '(... and not (list... -#### pffi-pointer-null - +#### make-c-null + -**pffi-pointer-null** -> pointer +**make-c-null** -> pointer Returns a new NULL pointer. -#### pffi-pointer-null? - +#### c-null? + -**pffi-pointer-null?** pointer -> boolean +**c-null?** pointer -> boolean Returns #t if given pointer is null pointer, #f otherwise. -#### pffi-pointer-allocate - +#### make-c-bytevector + -**pffi-pointer-allocate** size -> pointer +(make-c-bytevector *k*) +(make-c-bytevector *k* *fill*) -Returns newly allocated pointer of given size. +Returns a newly allocated C bytevector(pointer) of length k. If byte is given, +then all elements of the C bytevector are initialized to byte, otherwise the +contents of each element are unspecified. #### pffi-pointer-address -**pffi-pointer-address** pointer -> number +**pffi-pointer-address** pointer -> pointer -Returns the address of given pointer as number. +Returns the address of given pointer inside a pointer. This is used when +passing pointers to pointers to foreign procedures. This is similar to the +c's &. One **important difference** is that after you have passed a pointer to +the procedure you must get value from it back to the pointer which address you +are passing. Example: -#### pffi-pointer? + (define input-pointer (make-c-bytevector )) + (define input-pointer-address (pffi-pointer-address input-pointer)) + ( input-pointer-address) + (set! input-pointer (pffi-pointer-get input-pointer-address 'pointer 0)) + +#### c-bytevector? -**pffi-pointer?** object -> boolean +**c-bytevector?** object -> boolean Returns #t if given object is pointer, #f otherwise. -#### pffi-pointer-free - +#### c-free + -**pffi-pointer-free** pointer +**c-free** pointer Frees given pointer. @@ -448,7 +462,7 @@ Frees given pointer. Sets the value on a pointer on given offset. For example: - (define p (pffi-pointer-allocate 128)) + (define p (make-c-bytevector 128)) (pffi-pointer-set! p 'int 64 100) Would set the offset of 64, on pointer p to value 100. @@ -460,22 +474,22 @@ Would set the offset of 64, on pointer p to value 100. Gets the value from a pointer on given offset. For example: - (define p (pffi-pointer-allocate 128)) + (define p (make-c-bytevector 128)) (pffi-pointer-set! p 'int 64 100) (pffi-pointer-get p 'int 64) > 100 -#### pffi-string->pointer - +#### string->c-bytevector + -**pffi-string->pointer** string -> pointer +**string->c-bytevector** string -> pointer Makes pointer out of a given string. -#### pffi-pointer->string - +#### c-bytevector->string + -**pffi-pointer->string** pointer -> string +**c-bytevector->sring** pointer -> string Makes string out of a given pointer. @@ -581,17 +595,17 @@ Converts given list into C array of given type. Converts given C array into list of given type and length. -#### pffi-define-function - +#### define-c-procedure + -**pffi-define-function** scheme-name shared-object c-name return-type argument-types +**define-c-procedure** scheme-name shared-object c-name return-type argument-types Defines a new foreign function to be used from Scheme code. For example: (cond-expand - (windows (pffi-define-library libc-stdlib '("stdlib.h") "ucrtbase" '(""))) - (else (pffi-define-library libc-stdlib '("stdlib.h") "c" '("" "6")))) - (pffi-define-function c-puts libc-stdlib 'puts 'int '(pointer)) + (windows (define-c-library libc-stdlib '("stdlib.h") "ucrtbase" '(""))) + (else (define-c-library libc-stdlib '("stdlib.h") "c" '("" "6")))) + (define-c-procedure c-puts libc-stdlib 'puts 'int '(pointer)) (c-puts "Message brought to you by FFI!") #### pffi-define-callback @@ -603,11 +617,11 @@ Defines a new Sceme function to be used as callback to C code. For example: ; Load the shared library (cond-expand - (windows (pffi-define-library libc-stdlib '("stdlib.h") "ucrtbase" '())) - (else (pffi-define-library '("stdlib.h") "c" '("" "6")))) + (windows (define-c-library libc-stdlib '("stdlib.h") "ucrtbase" '())) + (else (define-c-library '("stdlib.h") "c" '("" "6")))) ; Define C function that takes a callback - (pffi-define-function qsort libc-stdlib 'qsort 'void '(pointer int int callback)) + (define-c-procedure qsort libc-stdlib 'qsort 'void '(pointer int int callback)) ; Define our callback (pffi-define-callback compare @@ -621,17 +635,17 @@ Defines a new Sceme function to be used as callback to C code. For example: ((< a b) -1))))) ; Create new array of ints to be sorted - (define array (pffi-pointer-allocate (* (pffi-size-of 'int) 3))) - (pffi-pointer-set! array 'int (* (pffi-size-of 'int) 0) 3) - (pffi-pointer-set! array 'int (* (pffi-size-of 'int) 1) 2) - (pffi-pointer-set! array 'int (* (pffi-size-of 'int) 2) 1) + (define array (make-c-bytevector (* (c-size-of 'int) 3))) + (pffi-pointer-set! array 'int (* (c-size-of 'int) 0) 3) + (pffi-pointer-set! array 'int (* (c-size-of 'int) 1) 2) + (pffi-pointer-set! array 'int (* (c-size-of 'int) 2) 1) (display array) (newline) ;> (3 2 1) ; Sort the array - (qsort array 3 (pffi-size-of 'int) compare) + (qsort array 3 (c-size-of 'int) compare) (display array) (newline) diff --git a/documentation/R7RS-PFFI.html b/documentation/R7RS-PFFI.html index aeb5c00..9c712d3 100644 --- a/documentation/R7RS-PFFI.html +++ b/documentation/R7RS-PFFI.html @@ -76,23 +76,22 @@ Documentation - 0.6.0
  • Procedures and macros
    • @@ -141,9 +139,7 @@ Documentation - 0.6.0

    Status

    -

    Currently the interface of the library is in okay shape. It - propably will not change much but no guarantees are being made - just yet.

    +

    In alpha.

    Current caveats

    Roadmap

    @@ -167,34 +163,26 @@ Documentation - 0.6.0

    Primitives

    - +
    - - - - + - - - - - + + + + - - - - - - - + + + - + @@ -207,10 +195,6 @@ Documentation - 0.6.0 - - - - @@ -222,10 +206,6 @@ Documentation - 0.6.0 - - - - @@ -234,23 +214,15 @@ Documentation - 0.6.0 - - - - - - - - @@ -263,18 +235,10 @@ Documentation - 0.6.0 - - - - - - - - @@ -292,10 +256,6 @@ Documentation - 0.6.0 - - - - @@ -306,17 +266,9 @@ Documentation - 0.6.0 - - - - - - - - @@ -332,10 +284,6 @@ Documentation - 0.6.0 - - - - @@ -348,10 +296,6 @@ Documentation - 0.6.0 - - - - @@ -362,17 +306,9 @@ Documentation - 0.6.0 - - - - - - - - @@ -386,10 +322,6 @@ Documentation - 0.6.0 - - - - @@ -404,10 +336,6 @@ Documentation - 0.6.0 - - - - @@ -418,10 +346,6 @@ Documentation - 0.6.0 - - - -
    pffi-initpffi-size-ofpffi-define-librarypffi-pointer-nullpffi-pointer-null?pffi-pointer-addresspffi-pointer?c-size-ofdefine-c-libraryc-bytevector? pffi-pointer-set! pffi-pointer-getpffi-definedefine-c-procedure pffi-define-callback
    X X XXXXX
    X X XXXXX
    Cyclone X X XXXX X
    Gambit XX X X X XXXXX
    GerbilX X X XXXXX
    Kawa X X XXXXX
    LarcenyX X X XXXX X X
    X X XXXXX
    Saggittarius X X XXXXX
    SkintX X X XXXX
    Ypsilon X X XXXXX
    @@ -430,8 +354,11 @@ Documentation - 0.6.0

    These features are built upon the primitives and if primitives are implemented and work, they should work too.

    Example:

    (cond-expand
-  (windows (pffi-define-library libc-stdlib
+  (windows (define-c-library libc-stdlib
                                 '("stdlib.h")
                                 "ucrtbase"
                                 '((additional-versions ("0" "6"))
                                   (additiona-paths (".")))))
-  (else (pffi-define-library libc-stdlib
+  (else (define-c-library libc-stdlib
                              (list "stdlib.h")
                              "c"
                              '((additional-versions ("0" "6"))
@@ -681,38 +608,47 @@ make <SCHEME>
  • As ’(… and not (list…
    • -

    pffi-pointer-null

    -

    -

    pffi-pointer-null -> pointer

    +

    make-c-null

    +

    +

    make-c-null -> pointer

    Returns a new NULL pointer.

    -

    pffi-pointer-null?

    -

    -

    pffi-pointer-null? pointer -> boolean

    +

    c-null?

    +

    +

    c-null? pointer -> boolean

    Returns #t if given pointer is null pointer, #f otherwise.

    -

    pffi-pointer-allocate

    -

    -

    pffi-pointer-allocate size -> pointer

    +

    make-c-bytevector

    +

    +

    make-c-bytevector size -> pointer

    Returns newly allocated pointer of given size.

    pffi-pointer-address

    pffi-pointer-address pointer -> - number

    -

    Returns the address of given pointer as number.

    -

    pffi-pointer?

    + pointer

    +

    Returns the address of given pointer inside a pointer. This + is used when passing pointers to pointers to foreign procedures. + This is similar to the c’s &. One important + difference is that after you have passed a pointer to + the procedure you must get value from it back to the pointer + which address you are passing. Example:

    + 
    (define input-pointer (make-c-bytevector <needed size>))
+(define input-pointer-address (pffi-pointer-address input-pointer))
+(<foreign-procedure-that takes &pointer as argument> input-pointer-address)
+(set! input-pointer (pffi-pointer-get input-pointer-address 'pointer 0))
    +

    c-bytevector?

    -

    pffi-pointer? object -> boolean

    +

    c-bytevector? object -> boolean

    Returns #t if given object is pointer, #f otherwise.

    -

    pffi-pointer-free

    -

    -

    pffi-pointer-free pointer

    +

    c-free

    +

    +

    c-free pointer

    Frees given pointer.

    pffi-pointer-set!

    pffi-pointer-set! pointer type offset value

    Sets the value on a pointer on given offset. For example:

    - 
    (define p (pffi-pointer-allocate 128))
+        
    (define p (make-c-bytevector 128))
 (pffi-pointer-set! p 'int 64 100)
    
         
    Would set the offset of 64, on pointer p to value 100.
    
         
    pffi-pointer-get
    
@@ -721,18 +657,18 @@ make <SCHEME>
    object

    Gets the value from a pointer on given offset. For example:

    - 
    (define p (pffi-pointer-allocate 128))
+        
    (define p (make-c-bytevector 128))
 (pffi-pointer-set! p 'int 64 100)
 (pffi-pointer-get p 'int 64)
 > 100
    
-        
    pffi-string->pointer
    
-        
    
-        
    pffi-string->pointer string ->
+        
    string->c-bytevector
    
+        
    
+        
    string->c-bytevector string ->
         pointer
    
         
    Makes pointer out of a given string.
    
-        
    pffi-pointer->string
    
-        
    
-        
    pffi-pointer->string pointer ->
+        
    c-bytevector->string
    
+        
    
+        
    c-bytevector->sring pointer ->
         string
    
         
    Makes string out of a given pointer.
    
         
    pffi-struct-make
    
@@ -804,16 +740,16 @@ make <SCHEME>

    pffi-array->list type list length

    Converts given C array into list of given type and length.

    -

    pffi-define-function

    -

    -

    pffi-define-function scheme-name - shared-object c-name return-type argument-types

    +

    define-c-procedure

    +

    +

    define-c-procedure scheme-name shared-object + c-name return-type argument-types

    Defines a new foreign function to be used from Scheme code. For example:

    (cond-expand
-    (windows (pffi-define-library libc-stdlib '("stdlib.h") "ucrtbase" '("")))
-    (else (pffi-define-library libc-stdlib '("stdlib.h")  "c" '("" "6"))))
-(pffi-define-function c-puts libc-stdlib 'puts 'int '(pointer))
+    (windows (define-c-library libc-stdlib '("stdlib.h") "ucrtbase" '("")))
+    (else (define-c-library libc-stdlib '("stdlib.h")  "c" '("" "6"))))
+(define-c-procedure c-puts libc-stdlib 'puts 'int '(pointer))
 (c-puts "Message brought to you by FFI!")

    pffi-define-callback

    @@ -823,11 +759,11 @@ make <SCHEME> code. For example:

    ; Load the shared library
 (cond-expand
-    (windows (pffi-define-library libc-stdlib '("stdlib.h") "ucrtbase" '()))
-    (else (pffi-define-library '("stdlib.h") "c" '("" "6"))))
+    (windows (define-c-library libc-stdlib '("stdlib.h") "ucrtbase" '()))
+    (else (define-c-library '("stdlib.h") "c" '("" "6"))))
 
 ; Define C function that takes a callback
-(pffi-define-function qsort libc-stdlib 'qsort 'void '(pointer int int callback))
+(define-c-procedure qsort libc-stdlib 'qsort 'void '(pointer int int callback))
 
 ; Define our callback
 (pffi-define-callback compare
@@ -841,17 +777,17 @@ make <SCHEME>
    ((< a b) -1))))) ; Create new array of ints to be sorted -(define array (pffi-pointer-allocate (* (pffi-size-of 'int) 3))) -(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 0) 3) -(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 1) 2) -(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 2) 1) +(define array (make-c-bytevector (* (c-size-of 'int) 3))) +(pffi-pointer-set! array 'int (* (c-size-of 'int) 0) 3) +(pffi-pointer-set! array 'int (* (c-size-of 'int) 1) 2) +(pffi-pointer-set! array 'int (* (c-size-of 'int) 2) 1) (display array) (newline) ;> (3 2 1) ; Sort the array -(qsort array 3 (pffi-size-of 'int) compare) +(qsort array 3 (c-size-of 'int) compare) (display array) (newline) diff --git a/documentation/R7RS-PFFI.pdf b/documentation/R7RS-PFFI.pdf index 2e6fcde..2ac5fa0 100644 Binary files a/documentation/R7RS-PFFI.pdf and b/documentation/R7RS-PFFI.pdf differ diff --git a/retropikzel/pffi.sld b/retropikzel/pffi.sld index 229e9b9..200c0c0 100644 --- a/retropikzel/pffi.sld +++ b/retropikzel/pffi.sld @@ -1,14 +1,15 @@ (define-library - (retropikzel pffi) + (retropikzel pffi) ; (foreign r7rs)? (foreign c)? (cond-expand (chibi - (import (scheme base) + (import (except (scheme base) bytevector-copy!) (scheme write) (scheme char) (scheme file) (scheme process-context) (chibi ast) - (chibi)) + (chibi) + (r6rs bytevectors)) (include-shared "pffi/chibi-pffi")) (chicken (import (scheme base) @@ -21,7 +22,8 @@ (chicken locative) (chicken syntax) (chicken memory) - (chicken random))) + (chicken random) + (r6rs bytevectors))) (cyclone (import (scheme base) (scheme write) @@ -29,14 +31,16 @@ (scheme file) (scheme process-context) (cyclone foreign) - (scheme cyclone primitives))) + (scheme cyclone primitives) + (r6rs bytevectors))) (gambit (import (scheme base) (scheme write) (scheme char) (scheme file) (scheme process-context) - (only (gambit) c-declare c-lambda c-define define-macro))) + (only (gambit) c-declare c-lambda c-define define-macro) + (r6rs bytevectors))) (gauche (import (scheme base) (scheme write) @@ -44,29 +48,32 @@ (scheme file) (scheme process-context) (gauche base) - (retropikzel pffi gauche))) + (retropikzel pffi gauche) + (r6rs bytevectors))) (gerbil (import (scheme base) (scheme write) (scheme char) (scheme file) - (scheme process-context))) + (scheme process-context) + (r6rs bytevectors))) (guile (import (scheme base) (scheme write) (scheme char) (scheme file) (scheme process-context) - (rnrs bytevectors) (system foreign) (system foreign-library) - (only (guile) include-from-path))) + (only (guile) include-from-path) + (rnrs bytevectors))) (kawa - (import (scheme base) + (import (except (scheme base) bytevector-copy bytevector-copy!) (scheme write) (scheme char) (scheme file) - (scheme process-context))) + (scheme process-context) + (r6rs bytevectors))) (larceny (import (scheme base) (scheme write) @@ -77,14 +84,16 @@ (primitives std-ffi) (primitives foreign-procedure) (primitives foreign-file) - (primitives foreign-stdlib))) + (primitives foreign-stdlib) + (r6rs bytevectors))) (mosh - (import (scheme base) + (import (except (scheme base) bytevector-copy!) (scheme write) (scheme char) (scheme file) (scheme process-context) - (mosh ffi))) + (mosh ffi) + (r6rs bytevectors))) (racket (import (scheme base) (scheme write) @@ -95,37 +104,87 @@ (ffi winapi) (compatibility mlist) (ffi unsafe) - (ffi vector))) + (ffi vector) + (except (r6rs bytevectors) bytevector-copy!))) (sagittarius (import (scheme base) (scheme write) (scheme char) (scheme file) (scheme process-context) - (sagittarius ffi) - (sagittarius))) + (except (sagittarius ffi) c-free c-malloc) + (sagittarius) + (r6rs bytevectors))) (skint (import (scheme base) (scheme write) (scheme char) (scheme file) - (scheme process-context))) + (scheme process-context) + (r6rs bytevectors))) (stklos (import (scheme base) (scheme write) (scheme char) (scheme file) (scheme process-context) - (stklos)) + (only (stklos) + make-external-function + allocate-bytes + free-bytes + cpointer? + cpointer-null? + cpointer-data + cpointer-data-set! + pointer-set-c-int8_t! + pointer-ref-c-int8_t + pointer-set-c-uint8_t! + pointer-ref-c-uint8_t + pointer-set-c-int16_t! + pointer-ref-c-int16_t + pointer-set-c-uint16_t! + pointer-ref-c-uint16_t + pointer-set-c-int32_t! + pointer-ref-c-int32_t + pointer-set-c-uint32_t! + pointer-ref-c-uint32_t + pointer-set-c-int64_t! + pointer-ref-c-int64_t + pointer-set-c-uint64_t! + pointer-ref-c-uint64_t + pointer-set-c-char! + pointer-ref-c-char + pointer-set-c-short! + pointer-ref-c-short + pointer-set-c-unsigned-short! + pointer-ref-c-unsigned-short + pointer-set-c-int! + pointer-ref-c-int + pointer-set-c-unsigned-int! + pointer-ref-c-unsigned-int + pointer-set-c-long! + pointer-ref-c-long + pointer-set-c-unsigned-long! + pointer-ref-c-unsigned-long + pointer-set-c-float! + pointer-ref-c-float + pointer-set-c-double! + pointer-ref-c-double + pointer-set-c-pointer! + pointer-ref-c-pointer + void?) + (r6rs bytevectors)) (export make-external-function calculate-struct-size-and-offsets - struct-make)) + struct-make + pffi:string-split)) (tr7 (import (scheme base) (scheme write) (scheme char) (scheme file) - (scheme process-context))) + (scheme process-context) + (r6rs bytevectors))) (ypsilon (import (scheme base) (scheme write) @@ -134,42 +193,67 @@ (scheme process-context) (ypsilon c-ffi) (ypsilon c-types) - (only (core) define-macro syntax-case)))) - (export pffi-init - pffi-size-of - pffi-type? - pffi-align-of - pffi-define-library - 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-define-struct - pffi-struct-pointer - pffi-struct-offset-get - pffi-struct-get - pffi-struct-set! - pffi-array-allocate - pffi-array-pointer - pffi-array? - pffi-pointer->array - pffi-array-get - pffi-array-set! - pffi-list->array - pffi-array->list - pffi-define-function - pffi-define-callback) + (only (core) define-macro syntax-case) + (except (rnrs bytevectors) + bytevector-copy! + bytevector-copy + string->utf8 + utf8->string)))) + (export ;; Primitives + c-size-of + define-c-library + define-c-procedure + ;pffi-define-callback; define-c-callback (?) + c-bytevector? + pffi-pointer-set!;c-bytevector-u8-set! and so on + pffi-pointer-get;c-bytevector-u8-ref and so on + + ;; c-bytevector + make-c-bytevector + c-bytevector ;; TODO Documentation, Testing + make-c-null + c-null? + c-free + c-bytevector-string-length ;; TODO Documentation, Testing + bytevector->c-bytevector + c-bytevector->bytevector + call-with-address-of-c-bytevector ;; Todo Documentation + string->c-bytevector + c-bytevector->string + + ;c-bytevector-u8-ref ;; TODO Documentation, Testing + + ;; c-struct + pffi-define-struct;define-c-struct + pffi-struct-pointer;c-struct-bytevector + pffi-struct-offset-get;c-struct-offset + pffi-struct-set!;c-struct-set! + pffi-struct-get;c-struct-get + + ;; c-array + ;define-c-array (?) + pffi-array-allocate;make-c-array + pffi-array-pointer;c-array-pointer + pffi-array?;c-array? + pffi-pointer->array;c-bytevector->array + pffi-array-get;c-array-get + pffi-array-set!;c-array-set! + pffi-list->array;list->c-array + pffi-array->list;c-array->list + + ;; c-variable + ;define-c-variable (?) + ) (cond-expand (chibi (include "pffi/chibi.scm")) - (chicken-5 (include "pffi/chicken.scm")) + (chicken-5 (export foreign-declare + foreign-safe-lambda + void) + (include "pffi/chicken.scm")) (chicken-6 (include-relative "pffi/chicken.scm")) - (cyclone (include "pffi/cyclone.scm")) + (cyclone (export calculate-struct-size-and-offsets + struct-make) + (include "pffi/cyclone.scm")) (gambit (include "pffi/gambit.scm")) (gauche (include "pffi/gauche.scm")) (gerbil (include "pffi/gerbil.scm")) @@ -182,14 +266,14 @@ (skint (include "pffi/skint.scm")) (stklos (include "pffi/stklos.scm")) (tr7 (include "pffi/tr7.scm")) - (ypsilon (include "pffi/ypsilon.scm"))) - ;(include "pffi/shared/union.scm") + (ypsilon (export c-function) + (include "pffi/ypsilon.scm"))) (cond-expand (chicken-6 (include-relative "pffi/shared/main.scm") - (include-relative "pffi/shared/pointer.scm") - (include-relative "pffi/shared/array.scm") - (include-relative "pffi/shared/struct.scm")) + (include-relative "pffi/shared/pointer.scm") + (include-relative "pffi/shared/array.scm") + (include-relative "pffi/shared/struct.scm")) (else (include "pffi/shared/main.scm") + (include "pffi/shared/struct.scm") (include "pffi/shared/pointer.scm") - (include "pffi/shared/array.scm") - (include "pffi/shared/struct.scm")))) + (include "pffi/shared/array.scm")))) diff --git a/retropikzel/pffi/chibi-src/pffi.stub b/retropikzel/pffi/chibi-src/pffi.stub index 7354e47..e46001a 100644 --- a/retropikzel/pffi/chibi-src/pffi.stub +++ b/retropikzel/pffi/chibi-src/pffi.stub @@ -4,7 +4,7 @@ (c-system-include "dlfcn.h") (c-system-include "ffi.h") -;; pffi-size-of +;; c-size-of (c-declare " int size_of_int8_t() { return sizeof(int8_t); } int size_of_uint8_t() { return sizeof(uint8_t); } @@ -47,7 +47,7 @@ (define-c int (size-of-double size_of_double) ()) (define-c int (size-of-pointer size_of_pointer) ()) -;; pffi-shape-object-load +;; pffi-shared-object-load (define-c-const int (RTLD-NOW "RTLD_NOW")) (define-c (maybe-null pointer void*) dlopen (string int)) (define-c (maybe-null pointer void*) dlerror ()) @@ -70,10 +70,10 @@ }") (define-c sexp (pointer? is_pointer) (sexp)) -(c-declare "intptr_t pointer_address(struct sexp_struct* pointer) { - return (intptr_t)&sexp_cpointer_value(pointer); +(c-declare "void* pointer_address(struct sexp_struct* pointer) { + return (void*)&sexp_cpointer_value(pointer); }") -(define-c uint32_t (pointer-address pointer_address) (sexp)) +(define-c (maybe-null pointer void*) (pointer-address pointer_address) (sexp)) (c-declare "void pointer_free(void* pointer) { free(pointer); }") (define-c void (pointer-free pointer_free) ((maybe-null pointer void*))) @@ -99,8 +99,8 @@ (c-declare "void pointer_set_c_uint64_t(void* pointer, int offset, uint64_t value) { *(uint64_t*)((char*)pointer + offset) = value; }") (define-c void (pointer-set-c-uint64_t! pointer_set_c_uint64_t) ((pointer void*) int uint64_t)) -(c-declare "void pointer_set_c_char(void* pointer, int offset, char value) { *((char*)pointer + offset) = value; }") -(define-c void (pointer-set-c-char! pointer_set_c_char) ((pointer void*) int char)) +(c-declare "void pointer_set_c_char(void* pointer, int offset, int8_t value) { *((char*)pointer + offset) = value; }") +(define-c void (pointer-set-c-char! pointer_set_c_char) ((pointer void*) int int8_t)) (c-declare "void pointer_set_c_unsigned_char(void* pointer, int offset, unsigned char value) { *(unsigned char*)((char*)pointer + offset) = value; }") (define-c void (pointer-set-c-unsigned-char! pointer_set_c_unsigned_char) ((pointer void*) int unsigned-char)) @@ -149,8 +149,8 @@ (c-declare "uint64_t pointer_ref_c_uint64_t(void* pointer, int offset) { return *(uint64_t*)((char*)pointer + offset); }") (define-c uint64_t (pointer-ref-c-uint64_t pointer_ref_c_uint64_t) ((pointer void*) int)) -(c-declare "char pointer_ref_c_char(void* pointer, int offset) { return *(char*)((char*)pointer + offset); }") -(define-c char (pointer-ref-c-char pointer_ref_c_char) ((pointer void*) int)) +(c-declare "int8_t pointer_ref_c_char(void* pointer, int offset) { return *(char*)((char*)pointer + offset); }") +(define-c int8_t (pointer-ref-c-char pointer_ref_c_char) ((pointer void*) int)) (c-declare "unsigned char pointer_ref_c_unsigned_char(void* pointer, int offset) { return *(unsigned char*)((char*)pointer + offset); }") (define-c unsigned-char (pointer-ref-c-unsigned-char pointer_ref_c_unsigned_char) ((pointer void*) int)) @@ -178,15 +178,7 @@ (c-declare "void* pointer_ref_c_pointer(void* pointer, int offset) { char* p = (char*)pointer + offset; return *(char**)p; }") (define-c (maybe-null pointer void*) (pointer-ref-c-pointer pointer_ref_c_pointer) ((pointer void*) int)) -;; pffi-string->pointer -;(c-declare "void* string_to_pointer(char* string) { return (void*)string; }") -;(define-c (maybe-null pointer void*) (string-to-pointer string_to_pointer) (string)) - -;; pffi-pointer->string -;(c-declare "char* pointer_to_string(void* pointer) { return (char*)pointer; }") -;(define-c string (pointer-to-string pointer_to_string) ((maybe-null pointer void*))) - -;; pffi-define-function +;; define-c-procedure (c-declare "ffi_cif cif;") (define-c (pointer void*) dlsym ((maybe-null pointer void*) string)) diff --git a/retropikzel/pffi/chibi.scm b/retropikzel/pffi/chibi.scm index c914484..2915a5c 100644 --- a/retropikzel/pffi/chibi.scm +++ b/retropikzel/pffi/chibi.scm @@ -29,32 +29,22 @@ (lambda (path options) (let ((shared-object (dlopen path RTLD-NOW)) (maybe-error (dlerror))) - (when (not (pffi-pointer-null? maybe-error)) - (error (pffi-pointer->string maybe-error))) + #;(when (not (pffi-pointer-null? maybe-error)) + (error (c-bytevector->string maybe-error))) shared-object))) -(define pffi-pointer-null - (lambda () - (pointer-null))) - -(define pffi-pointer-null? - (lambda (pointer) - (not pointer))) ; #f is null on Chibi - -(define pffi-pointer? +(define c-bytevector? (lambda (object) (or (equal? object #f) ; False can be null pointer (pointer? object)))) -(define pffi-pointer-allocate - (lambda (size) - (pointer-allocate size))) +(define make-c-bytevector + (lambda (k . byte) + (if (null? byte) + (pointer-allocate k) + (bytevector->c-bytevector (make-bytevector k byte))))) -(define pffi-pointer-address - (lambda (pointer) - (pointer-address pointer))) - -(define pffi-pointer-free +(define c-free (lambda (pointer) (pointer-free pointer))) @@ -68,7 +58,7 @@ ((equal? type 'uint32) (pointer-set-c-uint32_t! pointer offset value)) ((equal? type 'int64) (pointer-set-c-int64_t! pointer offset value)) ((equal? type 'uint64) (pointer-set-c-uint64_t! pointer offset value)) - ((equal? type 'char) (pointer-set-c-char! pointer offset value)) + ((equal? type 'char) (pointer-set-c-char! pointer offset (char->integer value))) ((equal? type 'short) (pointer-set-c-short! pointer offset value)) ((equal? type 'unsigned-short) (pointer-set-c-unsigned-short! pointer offset value)) ((equal? type 'int) (pointer-set-c-int! pointer offset value)) @@ -90,7 +80,7 @@ ((equal? type 'uint32) (pointer-ref-c-uint32_t pointer offset)) ((equal? type 'int64) (pointer-ref-c-int64_t pointer offset)) ((equal? type 'uint64) (pointer-ref-c-uint64_t pointer offset)) - ((equal? type 'char) (pointer-ref-c-char pointer offset)) + ((equal? type 'char) (integer->char (pointer-ref-c-char pointer offset))) ((equal? type 'short) (pointer-ref-c-short pointer offset)) ((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset)) ((equal? type 'int) (pointer-ref-c-int pointer offset)) @@ -102,14 +92,6 @@ ((equal? type 'void) (pointer-ref-c-pointer pointer offset)) ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset))))) -#;(define pffi-string->pointer - (lambda (string-content) - (string-to-pointer string-content))) - -#;(define pffi-pointer->string - (lambda (pointer) - (pointer-to-string pointer))) - (define pffi-type->native-type (lambda (type) (cond ((equal? type 'int8) 'int8_t) @@ -136,7 +118,7 @@ ((equal? type 'callback) '(maybe-null void*)) (else (error "pffi-type->native-type -- No such pffi type" type))))) -;; pffi-define-function +;; define-c-procedure (define pffi-type->libffi-type (lambda (type) @@ -166,7 +148,7 @@ (define argument->pointer (lambda (value type) (cond ((procedure? value) (scheme-procedure-to-pointer value)) - (else (let ((pointer (pffi-pointer-allocate (size-of-type type)))) + (else (let ((pointer (make-c-bytevector (size-of-type type)))) (pffi-pointer-set! pointer type 0 value) pointer))))) @@ -175,10 +157,10 @@ (dlerror) ;; Clean all previous errors (let ((c-function (dlsym shared-object c-name)) (maybe-dlerror (dlerror))) - (when (not (pffi-pointer-null? maybe-dlerror)) - (error (pffi-pointer->string maybe-dlerror))) + #;(when (not (pffi-pointer-null? maybe-dlerror)) + (error (c-bytevector->string maybe-dlerror))) (lambda arguments - (let ((return-value (pffi-pointer-allocate + (let ((return-value (make-c-bytevector (if (equal? return-type 'void) 0 (size-of-type return-type))))) @@ -193,7 +175,7 @@ (cond ((not (equal? return-type 'void)) (pffi-pointer-get return-value return-type 0)))))))) -(define-syntax pffi-define-function +(define-syntax define-c-procedure (syntax-rules () ((_ scheme-name shared-object c-name return-type argument-types) (define scheme-name diff --git a/retropikzel/pffi/chicken.scm b/retropikzel/pffi/chicken.scm index 370180e..af795b2 100644 --- a/retropikzel/pffi/chicken.scm +++ b/retropikzel/pffi/chicken.scm @@ -25,11 +25,11 @@ ((equal? type 'struct) 'c-pointer) (else (error "pffi-type->native-type -- No such pffi type" type)))) ) -(define pffi-pointer? +(define c-bytevector? (lambda (object) (pointer? object))) -(define-syntax pffi-define-function +(define-syntax define-c-procedure (er-macro-transformer (lambda (expr rename compare) (let* ((pffi-type->native-type ; Chicken has this procedure in three places @@ -136,18 +136,17 @@ ((equal? type 'string) (foreign-value "sizeof(void*)" int)) ((equal? type 'callback) (foreign-value "sizeof(void*)" int))))) -#;(define pffi-pointer-allocate - (lambda (size) - (allocate size))) - -(define pffi-pointer-address - (lambda (pointer) - (pointer->address pointer))) - -(define pffi-pointer-null +(define make-c-null (lambda () (address->pointer 0))) +(define-syntax define-c-library + (syntax-rules () + ((_ scheme-name headers object-name options) + (begin + (define scheme-name #t) + (pffi-shared-object-load headers))))) + (define-syntax pffi-shared-object-load (er-macro-transformer (lambda (expr rename compare) @@ -158,13 +157,7 @@ `(foreign-declare ,(string-append "#include <" header ">"))) headers)))))) -#;(define pffi-pointer-free - (lambda (pointer) - (if (not (pointer? pointer)) - (error "pffi-pointer-free -- Argument is not pointer" pointer)) - (free pointer))) - -(define pffi-pointer-null? +(define c-null? (lambda (pointer) (if (and (not (pointer? pointer)) pointer) @@ -215,8 +208,3 @@ ((equal? type 'float) (pointer-f32-ref (pointer+ pointer offset))) ((equal? type 'double) (pointer-f64-ref (pointer+ pointer offset))) ((equal? type 'pointer) (address->pointer (pointer-u64-ref (pointer+ pointer offset))))))) - -(define pffi-struct-dereference - (lambda (struct) - (pffi-pointer-address (pffi-struct-pointer struct)))) - diff --git a/retropikzel/pffi/cyclone.scm b/retropikzel/pffi/cyclone.scm index 6948847..05d00b8 100644 --- a/retropikzel/pffi/cyclone.scm +++ b/retropikzel/pffi/cyclone.scm @@ -23,23 +23,23 @@ ((equal? type 'struct) 'c-pointer) (else (error "pffi-type->native-type -- No such pffi type" type))))) -(define pffi-pointer? +(define c-bytevector? (lambda (object) (opaque? object))) -(define-syntax pffi-define-function +(define-syntax define-c-procedure (er-macro-transformer (lambda (expr rename compare) (let* ((pffi-type->native-type (lambda (type) - (cond ((equal? type 'int8) 'byte) - ((equal? type 'uint8) 'unsigned-byte) - ((equal? type 'int16) 'int16_t) - ((equal? type 'uint16) 'uint16_t) - ((equal? type 'int32) 'int32) - ((equal? type 'uint32) 'unsigned-int32) - ((equal? type 'int64) 'integer-64) - ((equal? type 'uint64) 'unsigned-integer64) + (cond ((equal? type 'int8) 'int) + ((equal? type 'uint8) 'int) + ((equal? type 'int16) 'int) + ((equal? type 'uint16) 'int) + ((equal? type 'int32) 'int) + ((equal? type 'uint32) 'int) + ((equal? type 'int64) 'int) + ((equal? type 'uint64) 'int) ((equal? type 'char) 'char) ((equal? type 'unsigned-char) 'unsigned-char) ((equal? type 'short) 'short) @@ -50,22 +50,21 @@ ((equal? type 'unsigned-long) 'unsigned-long) ((equal? type 'float) 'float) ((equal? type 'double) 'double) - ((equal? type 'pointer) 'c-pointer) - ((equal? type 'void) 'void) - ((equal? type 'struct) 'c-pointer) + ((equal? type 'pointer) 'opaque) + ((equal? type 'void) 'c-void) (else (error "pffi-type->native-type -- No such pffi type" type))))) - (scheme-name (car (cdr expr))) + (scheme-name (cadr expr)) (c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr)))))))) (return-type (pffi-type->native-type (car (cdr (car (cdr (cdr (cdr (cdr expr))))))))) (argument-types - (let ((types (cdr (car (cdr (cdr (cdr (cdr (cdr expr))))))))) + (let ((types (cadr (car (cdr (cdr (cdr (cdr (cdr expr))))))))) (if (null? types) '() - (map pffi-type->native-type (map car (map cdr types))))))) + (map pffi-type->native-type types))))) (if (null? argument-types) `(c-define ,scheme-name ,return-type ,c-name) `(c-define ,scheme-name - ,return-type ,c-name ,@ argument-types)))))) + ,return-type ,c-name ,@argument-types)))))) (define pffi-define-callback (lambda (scheme-name return-type argument-types procedure) @@ -93,38 +92,31 @@ ((equal? type 'double) (c-value "sizeof(double)" int)) ((equal? type 'pointer) (c-value "sizeof(void*)" int))))) -#;(define-c pffi-pointer-allocate - "(void *data, int argc, closure _, object k, object size)" - "make_c_opaque(opq, malloc(obj_obj2int(size))); +(define-c pffi-pointer-address + "(void *data, int argc, closure _, object k, object pointer)" + "make_c_opaque(opq, &(void*)opaque_ptr(pointer)); return_closcall1(data, k, &opq);") (define pffi-pointer-null (lambda () (make-opaque))) -#;(define-c pffi-string->pointer - "(void *data, int argc, closure _, object k, object s)" - "make_c_opaque(opq, string_str(s)); - return_closcall1(data, k, &opq);") - -#;(define-c pffi-pointer->string - "(void *data, int argc, closure _, object k, object p)" - "make_string(s, opaque_ptr(p)); - return_closcall1(data, k, &s);") +(define-syntax define-c-library + (syntax-rules () + ((_ scheme-name headers object-name options) + (begin + (define scheme-name #t) + (pffi-shared-object-load headers))))) (define-syntax pffi-shared-object-load (er-macro-transformer (lambda (expr rename compare) - `(begin - ,@ (map - (lambda (header) - `(include-c-header ,(string-append "<" header ">"))) - (cdr (car (cdr expr)))))))) - -#;(define-c pffi-pointer-free - "(void *data, int argc, closure _, object k, object pointer)" - "free(opaque_ptr(pointer)); - return_closcall1(data, k, make_boolean(boolean_t));") + (let* ((headers (cadr (cadr expr))) + (includes (map + (lambda (header) + `(include-c-header ,(string-append "<" header ">"))) + headers))) + `(,@includes))))) (define pffi-pointer-null? (lambda (pointer) diff --git a/retropikzel/pffi/gambit.scm b/retropikzel/pffi/gambit.scm index b7aef6c..3c2d145 100644 --- a/retropikzel/pffi/gambit.scm +++ b/retropikzel/pffi/gambit.scm @@ -1,11 +1,6 @@ (c-declare "#include ") (c-declare "#include ") -(define-macro - (pffi-init) - `(begin (c-define-type pointer (pointer void)) - (c-define-type callback (pointer void)))) - (define size-of-int8_t (c-lambda () int "___return(sizeof(int8_t));")) (define size-of-uint8_t (c-lambda () int "___return(sizeof(uint8_t));")) (define size-of-int16_t (c-lambda () int "___return(sizeof(int16_t));")) @@ -52,16 +47,18 @@ (else (error "Can not get size of unknown type" type))))) (define-macro - (pffi-define-library name headers object-name . options) - `(begin (define ,name #t) - (c-declare ,(apply string-append - (map - (lambda (header) - (string-append "#include <" header ">" (string #\newline))) - (cdr headers)))))) + (define-c-library name headers object-name . options) + (begin + (let ((c-code (apply string-append + (map + (lambda (header) + (string-append "#include <" header ">" (string #\newline))) + (car (cdr headers)))))) + `(begin (define ,name #t) (c-declare ,c-code))))) + (define pointer? (c-lambda ((pointer void)) bool "___return(1);")) -(define pffi-pointer? +(define c-bytevector? (lambda (object) (call-with-current-continuation (lambda (k) @@ -69,20 +66,6 @@ (lambda (x) #f) (lambda () (pointer? object))))))) -(define pffi-pointer-null (c-lambda () (pointer void) "void* p = NULL; ___return(p);")) - -(define pointer-null? (c-lambda ((pointer void)) bool "if(___arg1 == NULL) { ___return(1); } else { ___return(0); }")) -(define pffi-pointer-null? - (lambda (pointer) - (and (pffi-pointer? pointer) - (pointer-null? pointer)))) - -;(define pffi-pointer-allocate (c-lambda (int) (pointer void) "void* p = malloc(___arg1); ___return(p);")) - -(define pffi-pointer-address (c-lambda ((pointer void)) ptrdiff_t "void* p = ___arg1; ___return((intptr_t)&p);")) - -;(define pffi-pointer-free (c-lambda ((pointer void)) void "free(___arg1);")) - (define pointer-set-c-int8_t! (c-lambda ((pointer void) int int8) void "*(int8_t*)((char*)___arg1 + ___arg2) = ___arg3;")) (define pointer-set-c-uint8_t! (c-lambda ((pointer void) int unsigned-int8) void "*(uint8_t*)((char*)___arg1 + ___arg2) = ___arg3;")) (define pointer-set-c-int16_t! (c-lambda ((pointer void) int int16) void "*(int16_t*)((char*)___arg1 + ___arg2) = ___arg3;")) @@ -167,31 +150,57 @@ ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset))))) (define-macro - (pffi-define-function scheme-name shared-object c-name return-type argument-types) - (letrec* ((native-argument-types - (if (equal? '(list) argument-types) - (list) - (let ((types (map cdr (cdr argument-types)))) - (if (null? types) types (map car types))))) - (native-return-type (car (cdr return-type))) - (c-arguments (lambda (index argument-count result) - (if (> index argument-count) - result - (c-arguments (+ index 1) - argument-count - (string-append result - "___arg" - (number->string index) - (if (< index argument-count) - ", " - "")))))) - (c-code (string-append - (if (equal? 'void (cadr return-type)) "" "___return(") - (symbol->string (cadr c-name)) - "(" (c-arguments 1 (- (length argument-types) 1) "") ")" - (if (equal? 'void (cadr return-type)) "" ")") - ";"))) - `(define ,scheme-name - (c-lambda ,native-argument-types - ,native-return-type - ,c-code)))) + (define-c-procedure scheme-name shared-object c-name return-type argument-types) + (begin + (letrec* ((pffi-type->native-type + (lambda (type) + (cond ((equal? type 'int8) 'byte) + ((equal? type 'uint8) 'unsigned-int8) + ((equal? type 'int16) 'int16_t) + ((equal? type 'uint16) 'uint16_t) + ((equal? type 'int32) 'int32) + ((equal? type 'uint32) 'unsigned-int32) + ((equal? type 'int64) 'int64) + ((equal? type 'uint64) 'unsigned-int64) + ((equal? type 'char) 'char) + ((equal? type 'unsigned-char) 'unsigned-char) + ((equal? type 'short) 'short) + ((equal? type 'unsigned-short) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'unsigned-int) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'unsigned-long) 'unsigned-long) + ((equal? type 'float) 'float) + ((equal? type 'double) 'double) + ((equal? type 'pointer) '(pointer void)) + ((equal? type 'void) 'void) + ((equal? type 'callback) 'c-pointer) + ((equal? type 'struct) 'c-pointer) + (else (error "pffi-type->native-type -- No such pffi type" type))))) + (native-argument-types + (if (equal? '(list) argument-types) + (list) + (let ((types (map pffi-type->native-type (cadr argument-types)))) + (if (null? types) types types)))) + (native-return-type (pffi-type->native-type (cadr return-type))) + (argument-count (length native-argument-types)) + (c-arguments (lambda (index result) + (if (>= index argument-count) + result + (c-arguments (+ index 1) + (string-append result + "___arg" + (number->string (+ index 1)) + (if (<= index (- argument-count 2)) + ", " + "")))))) + (c-code (string-append + (if (equal? 'void (cadr return-type)) "" "___return(") + (symbol->string (cadr c-name)) + "(" (c-arguments 0 "") ")" + (if (equal? 'void (cadr return-type)) "" ")") + ";"))) + `(define ,scheme-name + (c-lambda ,native-argument-types + ,native-return-type + ,c-code))))) diff --git a/retropikzel/pffi/gauche-src/gauchelib.scm b/retropikzel/pffi/gauche-src/gauchelib.scm index 403864f..d801f43 100644 --- a/retropikzel/pffi/gauche-src/gauchelib.scm +++ b/retropikzel/pffi/gauche-src/gauchelib.scm @@ -71,8 +71,6 @@ (define-cproc pointer-get-double (pointer offset::) pointer_get_double) (define-cproc pointer-get-pointer (pointer offset::) pointer_get_pointer) - (define-cproc string->pointer (string-content) string_to_pointer) - (define-cproc pointer->string (pointer) pointer_to_string) (define-cproc dlerror () pffi_dlerror) (define-cproc dlsym (shared-object c-name) pffi_dlsym) (define-cproc internal-ffi-call (nargs rtype atypes fn rvalue avalues) internal_ffi_call) diff --git a/retropikzel/pffi/gauche.scm b/retropikzel/pffi/gauche.scm index 3102bbd..ec70147 100644 --- a/retropikzel/pffi/gauche.scm +++ b/retropikzel/pffi/gauche.scm @@ -1,17 +1,15 @@ (define-module retropikzel.pffi.gauche (export size-of-type pffi-shared-object-load - pffi-pointer-null - pffi-pointer-null? - pffi-pointer-allocate + ;pffi-pointer-null + ;pffi-pointer-null? + make-c-bytevector pffi-pointer-address - pffi-pointer? - pffi-pointer-free + c-bytevector? + c-free pffi-pointer-set! pffi-pointer-get - pffi-string->pointer - pffi-pointer->string - pffi-define-function)) + define-c-procedure)) (select-module retropikzel.pffi.gauche) (dynamic-load "retropikzel/pffi/gauche-pffi") @@ -45,27 +43,15 @@ (lambda (path options) (shared-object-load path))) -(define pffi-pointer-null - (lambda () - (pointer-null))) - -(define pffi-pointer-null? - (lambda (pointer) - (pointer-null? pointer))) - -(define pffi-pointer-allocate +(define make-c-bytevector (lambda (size) (pointer-allocate size))) -(define pffi-pointer-address - (lambda (object) - (pointer-address object))) - -(define pffi-pointer? +(define c-bytevector? (lambda (pointer) (pointer? pointer))) -(define pffi-pointer-free +(define c-free (lambda (pointer) (pointer-free pointer))) @@ -141,7 +127,7 @@ (define argument->pointer (lambda (value type) (cond ((procedure? value) (scheme-procedure-to-pointer value)) - (else (let ((pointer (pffi-pointer-allocate (size-of-type type)))) + (else (let ((pointer (make-c-bytevector (size-of-type type)))) (pffi-pointer-set! pointer type 0 value) pointer))))) @@ -150,10 +136,10 @@ (dlerror) ;; Clean all previous errors (let ((c-function (dlsym shared-object c-name)) (maybe-dlerror (dlerror))) - (when (not (pffi-pointer-null? maybe-dlerror)) - (error (pffi-pointer->string maybe-dlerror))) + #;(when (not (pffi-pointer-null? maybe-dlerror)) + (error (c-bytevector->string maybe-dlerror))) (lambda arguments - (let ((return-value (pffi-pointer-allocate + (let ((return-value (make-c-bytevector (if (equal? return-type 'void) 0 (size-of-type return-type))))) @@ -168,7 +154,7 @@ (cond ((not (equal? return-type 'void)) (pffi-pointer-get return-value return-type 0)))))))) -(define-syntax pffi-define-function +(define-syntax define-c-procedure (syntax-rules () ((_ scheme-name shared-object c-name return-type argument-types) (define scheme-name diff --git a/retropikzel/pffi/gerbil.scm b/retropikzel/pffi/gerbil.scm index cd726ad..a780a83 100644 --- a/retropikzel/pffi/gerbil.scm +++ b/retropikzel/pffi/gerbil.scm @@ -2,11 +2,11 @@ (lambda (type) (error "Not defined"))) -(define pffi-pointer? +(define c-bytevector? (lambda (object) (error "Not defined"))) -(define-syntax pffi-define-function +(define-syntax define-c-procedure (syntax-rules () ((_ scheme-name shared-object c-name return-type argument-types) (error "Not defined")))) @@ -15,34 +15,10 @@ (lambda (type) (error "Not defined"))) -(define pffi-pointer-allocate - (lambda (size) - (error "Not defined"))) - -(define pffi-pointer-null - (lambda () - (error "Not defined"))) - -#;(define pffi-string->pointer - (lambda (string-content) - (error "Not defined"))) - -#;(define pffi-pointer->string - (lambda (pointer) - pointer)) - (define pffi-shared-object-load (lambda (header path) (error "Not defined"))) -(define pffi-pointer-free - (lambda (pointer) - (error "Not defined"))) - -(define pffi-pointer-null? - (lambda (pointer) - (error "Not defined"))) - (define pffi-pointer-set! (lambda (pointer type offset value) (let ((p pointer)) @@ -51,7 +27,3 @@ (define pffi-pointer-get (lambda (pointer type offset) (error "Not defined"))) - -(define pffi-pointer-deref - (lambda (pointer) - (error "Not defined"))) diff --git a/retropikzel/pffi/guile.scm b/retropikzel/pffi/guile.scm index d776977..01d2d21 100644 --- a/retropikzel/pffi/guile.scm +++ b/retropikzel/pffi/guile.scm @@ -25,11 +25,11 @@ ((equal? type 'struct) '*) (else #f)))) -(define pffi-pointer? +(define c-bytevector? (lambda (object) (pointer? object))) -(define-syntax pffi-define-function +(define-syntax define-c-procedure (syntax-rules () ((_ scheme-name shared-object c-name return-type argument-types) (define scheme-name @@ -53,39 +53,10 @@ (native-type (sizeof native-type)) (else #f))))) -#;(define pffi-pointer-allocate - (lambda (size) - (bytevector->pointer (make-bytevector size 0)))) - -(define pffi-pointer-address - (lambda (pointer) - (pointer-address pointer))) - -(define pffi-pointer-null - (lambda () - (make-pointer 0))) - -#;(define pffi-string->pointer - (lambda (string-content) - (string->pointer string-content))) - -#;(define pffi-pointer->string - (lambda (pointer) - (pointer->string pointer))) - (define pffi-shared-object-load (lambda (path options) (load-foreign-library path))) -#;(define pffi-pointer-free - (lambda (pointer) - #t)) - -(define pffi-pointer-null? - (lambda (pointer) - (and (pffi-pointer? pointer) - (null-pointer? pointer)))) - (define pffi-pointer-set! (lambda (pointer type offset value) (let ((p (pointer->bytevector pointer (+ offset 100)))) @@ -106,8 +77,7 @@ ((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) (size-of-type type))) - ((equal? type 'string) (bytevector-sint-set! p offset (pointer-address (pffi-string->pointer value)) (native-endianness) (size-of-type type))))))) + ((equal? type 'pointer) (bytevector-sint-set! p offset (pointer-address value) (native-endianness) (size-of-type type))))))) (define pffi-pointer-get (lambda (pointer type offset) @@ -129,9 +99,4 @@ ((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) (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) - (dereference-pointer (pffi-struct-pointer struct)))) + ((equal? type 'pointer) (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type)))))))) diff --git a/retropikzel/pffi/kawa.scm b/retropikzel/pffi/kawa.scm index 0ce506b..e9e91c9 100644 --- a/retropikzel/pffi/kawa.scm +++ b/retropikzel/pffi/kawa.scm @@ -54,14 +54,14 @@ ((equal? type 'struct) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8)) (else #f)))) -(define pffi-pointer? +(define c-bytevector? (lambda (object) (string=? (invoke (invoke object 'getClass) 'getName) "jdk.internal.foreign.NativeMemorySegmentImpl"))) -(define-syntax pffi-define-function +(define-syntax define-c-procedure (syntax-rules () - ((pffi-define-function scheme-name shared-object c-name return-type argument-types) + ((_ scheme-name shared-object c-name return-type argument-types) (define scheme-name (lambda vals (invoke (invoke (cdr (assoc 'linker shared-object)) @@ -131,28 +131,10 @@ (invoke native-type 'byteAlignment) #f)))) -#;(define pffi-pointer-allocate - (lambda (size) - (invoke (invoke arena 'allocate size 1) 'reinterpret size))) - -(define pffi-pointer-address - (lambda (pointer) - (invoke pointer 'address))) - -(define pffi-pointer-null +(define make-c-null (lambda () (static-field java.lang.foreign.MemorySegment 'NULL))) -#;(define pffi-string->pointer - (lambda (string-content) - (let ((size (+ (invoke string-content 'length) 1))) - (invoke (invoke arena 'allocateFrom (invoke string-content 'toString)) - 'reinterpret size)))) - -#;(define pffi-pointer->string - (lambda (pointer) - (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'getString 0))) - (define pffi-shared-object-load (lambda (path options) (let* ((library-file (make java.io.File path)) @@ -169,11 +151,7 @@ (list (cons 'linker linker) (cons 'lookup lookup))))) -#;(define pffi-pointer-free - (lambda (pointer) - #t)) - -(define pffi-pointer-null? +(define c-null? (lambda (pointer) (invoke pointer 'equals (pffi-pointer-null)))) diff --git a/retropikzel/pffi/larceny.scm b/retropikzel/pffi/larceny.scm index 8f92241..656c792 100644 --- a/retropikzel/pffi/larceny.scm +++ b/retropikzel/pffi/larceny.scm @@ -1,6 +1,4 @@ (require 'std-ffi) -;(require "Standard/foreign-stdlib") -;(require "Lib/Common/system-interface") ;; FIXME (define size-of-type @@ -28,49 +26,12 @@ ((eq? type 'callback) 4) (else (error "Can not get size of unknown type" type))))) -(define c-malloc (foreign-procedure "malloc" '(int) 'void*)) -;(define c-malloc (stdlib/malloc rtd-void*)) -#;(define pffi-pointer-allocate - (lambda (size) - (c-malloc size))) - -#;(define c-free (foreign-procedure "free" '(void*) 'int)) -;(define c-malloc (stdlib/malloc rtd-void*)) -#;(define pffi-pointer-free - (lambda (pointer) - (c-free pointer))) - -(define pffi-pointer-null (lambda () 0)) - -(define pffi-pointer-null? - (lambda (object) - (and (number? object) - (= object 0)))) - -(define pffi-pointer? +(define c-bytevector? (lambda (object) ;(void*? object) (number? object) )) -(define pffi-pointer-address - (lambda (pointer) - ;(void*->address pointer) - pointer - )) - -(define pffi-pointer->string - (lambda (pointer) - ;(char*->string pointer) - pointer - )) - -(define pffi-string->pointer - (lambda (string-content) - ;(string->char* string-content) - string-content - )) - (define pffi-shared-object-load (lambda (headers path . options) (foreign-file path))) @@ -122,7 +83,7 @@ ((equal? type 'void) (%peek-pointer (+ pointer offset))) ((equal? type 'pointer) (%peek-pointer (+ pointer offset)))))) -(define-syntax pffi-define-function +(define-syntax define-c-procedure (syntax-rules () ((_ scheme-name shared-object c-name return-type argument-types) (define scheme-name diff --git a/retropikzel/pffi/mosh.scm b/retropikzel/pffi/mosh.scm index 5a15eca..3395f22 100644 --- a/retropikzel/pffi/mosh.scm +++ b/retropikzel/pffi/mosh.scm @@ -25,33 +25,13 @@ (else #f)))) (define pffi-shared-object-load - (lambda (path . options) + (lambda (path options) (open-shared-library path))) -(define pffi-pointer-null - (lambda () - pointer-null)) - -(define pffi-pointer-null? - (lambda (pointer) - (pointer-null? pointer))) - -#;(define pffi-pointer-allocate - (lambda (size) - (malloc size))) - -(define pffi-pointer-address - (lambda (pointer) - (pointer->integer pointer))) - -(define pffi-pointer? +(define c-bytevector? (lambda (object) (pointer? object))) -#;(define pffi-pointer-free - (lambda (pointer) - (free pointer))) - (define pffi-pointer-set! (lambda (pointer type offset value) (cond ((equal? type 'int8) (pointer-set-c-int8! pointer offset value)) @@ -96,22 +76,6 @@ ((equal? type 'void) (pointer-ref-c-pointer pointer offset)) ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset))))) -#;(define pffi-string->pointer - (lambda (string-content) - (let ((pointer (pffi-pointer-allocate (+ (string-length string-content) 1))) - (index 0)) - (string-for-each - (lambda (c) - (pffi-pointer-set! pointer 'char (* index (size-of-type 'char)) c) - (set! index (+ index 1))) - string-content) - (pffi-pointer-set! pointer 'char (* index (size-of-type 'char)) #\null) - pointer))) - -#;(define pffi-pointer->string - (lambda (pointer) - (pointer->string pointer))) - (define pffi-type->native-type (lambda (type) (cond ((equal? type 'int8) 'int8_t) @@ -139,7 +103,7 @@ ((equal? type 'struct) 'void*) (else (error "pffi-type->native-type -- No such pffi type" type))))) -(define-syntax pffi-define-function +(define-syntax define-c-procedure (syntax-rules () ((_ scheme-name shared-object c-name return-type argument-types) (define scheme-name @@ -155,7 +119,3 @@ (make-c-callback (pffi-type->native-type return-type) (map pffi-type->native-type argument-types) procedure))))) - -#;(define pffi-struct-dereference - (lambda (struct) - (pffi-struct-pointer struct))) diff --git a/retropikzel/pffi/racket.scm b/retropikzel/pffi/racket.scm index e890647..3cfb1f2 100644 --- a/retropikzel/pffi/racket.scm +++ b/retropikzel/pffi/racket.scm @@ -21,15 +21,14 @@ ((equal? type 'pointer) _pointer) ((equal? type 'void) _void) ((equal? type 'callback) _pointer) - ((equal? type 'string) _pointer) ((equal? type 'struct) _pointer) (else #f)))) -(define pffi-pointer? +(define c-bytevector? (lambda (object) (cpointer? object))) -(define-syntax pffi-define-function +(define-syntax define-c-procedure (syntax-rules () ((_ scheme-name shared-object c-name return-type argument-types) (define scheme-name @@ -53,31 +52,6 @@ (ctype-sizeof native-type) #f)))) -#;(define pffi-pointer-allocate - (lambda (size) - (malloc 'raw size))) - -(define pffi-pointer-address - (lambda (pointer) - pointer)) - -(define pffi-pointer-null - (lambda () - #f )) ; #f is the null pointer on racket - -#;(define pffi-string->pointer - (lambda (string-content) - (let* ((size (string-length string-content)) - (pointer (pffi-pointer-allocate (+ size 1)))) - (memmove pointer (cast (string-append string-content "") _string _pointer) (+ size 1)) - pointer))) - -#;(define pffi-pointer->string - (lambda (pointer) - (when (pffi-pointer-null? pointer) - (error "Can not make string from null pointer" pointer)) - (string-copy (cast pointer _pointer _string)))) - (define pffi-shared-object-load (lambda (path options) (if (and (not (null? options)) @@ -87,14 +61,6 @@ (list #f)))) (ffi-lib path)))) -#;(define pffi-pointer-free - (lambda (pointer) - (free pointer))) - -(define pffi-pointer-null? - (lambda (pointer) - (not pointer))) ; #f is the null pointer on racket - (define pffi-pointer-set! (lambda (pointer type offset value) (ptr-set! pointer @@ -114,7 +80,3 @@ (if (equal? type 'char) (integer->char r) r)))) - -#;(define pffi-struct-dereference - (lambda (struct) - (pffi-struct-pointer struct))) diff --git a/retropikzel/pffi/sagittarius.scm b/retropikzel/pffi/sagittarius.scm index 98df939..f2aab32 100644 --- a/retropikzel/pffi/sagittarius.scm +++ b/retropikzel/pffi/sagittarius.scm @@ -1,3 +1,33 @@ +(define size-of-type + (lambda (type) + (cond ((eq? type 'int8) size-of-int8_t) + ((eq? type 'uint8) size-of-uint8_t) + ((eq? type 'int16) size-of-int16_t) + ((eq? type 'uint16) size-of-uint16_t) + ((eq? type 'int32) size-of-int32_t) + ((eq? type 'uint32) size-of-uint32_t) + ((eq? type 'int64) size-of-int64_t) + ((eq? type 'uint64) size-of-uint64_t) + ((eq? type 'char) size-of-char) + ((eq? type 'unsigned-char) size-of-char) + ((eq? type 'short) size-of-short) + ((eq? type 'unsigned-short) size-of-unsigned-short) + ((eq? type 'int) size-of-int) + ((eq? type 'unsigned-int) size-of-unsigned-int) + ((eq? type 'long) size-of-long) + ((eq? type 'unsigned-long) size-of-unsigned-long) + ((eq? type 'float) size-of-float) + ((eq? type 'double) size-of-double) + ((eq? type 'pointer) size-of-void*) + ((eq? type 'void) 0) + ((eq? type 'string) size-of-void*) + ((eq? type 'callback) size-of-void*) + (else #f)))) + +(define pffi-shared-object-load + (lambda (path options) + (open-shared-library path))) + (define pffi-type->native-type (lambda (type) (cond ((equal? type 'int8) 'int8_t) @@ -25,11 +55,7 @@ ((and (pair? type) (equal? 'struct (car type))) 'void*) (else #f)))) -(define pffi-pointer? - (lambda (object) - (pointer? object))) - -(define-syntax pffi-define-function +(define-syntax define-c-procedure (syntax-rules () ((_ scheme-name shared-object c-name return-type argument-types) (define scheme-name @@ -46,72 +72,9 @@ (map pffi-type->native-type argument-types) procedure))))) -(define size-of-type - (lambda (type) - (cond ((eq? type 'int8) size-of-int8_t) - ((eq? type 'uint8) size-of-uint8_t) - ((eq? type 'int16) size-of-int16_t) - ((eq? type 'uint16) size-of-uint16_t) - ((eq? type 'int32) size-of-int32_t) - ((eq? type 'uint32) size-of-uint32_t) - ((eq? type 'int64) size-of-int64_t) - ((eq? type 'uint64) size-of-uint64_t) - ((eq? type 'char) size-of-char) - ((eq? type 'unsigned-char) size-of-char) - ((eq? type 'short) size-of-short) - ((eq? type 'unsigned-short) size-of-unsigned-short) - ((eq? type 'int) size-of-int) - ((eq? type 'unsigned-int) size-of-unsigned-int) - ((eq? type 'long) size-of-long) - ((eq? type 'unsigned-long) size-of-unsigned-long) - ((eq? type 'float) size-of-float) - ((eq? type 'double) size-of-double) - ((eq? type 'pointer) size-of-void*) - ((eq? type 'void) 0) - ((eq? type 'string) size-of-void*) - ((eq? type 'callback) size-of-void*) - (else #f)))) - -#;(define pffi-pointer-allocate - (lambda (size) - (c-malloc size))) - -(define pffi-pointer-address - (lambda (pointer) - (address pointer))) - -(define pffi-pointer-null - (lambda () - (empty-pointer))) - -#;(define (string->c-string s) - (let* ((bv (string->utf8 s)) - (p (allocate-pointer (+ (bytevector-length bv) 1)))) - (do ((i 0 (+ i 1))) - ((= i (bytevector-length bv)) p) - (pointer-set-c-uint8! p i (bytevector-u8-ref bv i))) - p)) - -#;(define pffi-string->pointer - (lambda (string-content) - (string->c-string string-content))) - -#;(define pffi-pointer->string - (lambda (pointer) - (pointer->string pointer))) - -(define pffi-shared-object-load - (lambda (path options) - (open-shared-library path))) - -#;(define pffi-pointer-free - (lambda (pointer) - (when (pointer? pointer) - (c-free pointer)))) - -(define pffi-pointer-null? - (lambda (pointer) - (null-pointer? pointer))) +(define c-bytevector? + (lambda (object) + (pointer? object))) (define pffi-pointer-set! (lambda (pointer type offset value) @@ -156,3 +119,4 @@ ((equal? type 'double) (pointer-ref-c-double pointer offset)) ((equal? type 'void) (pointer-ref-c-pointer pointer offset)) ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset))))) + diff --git a/retropikzel/pffi/shared/array.scm b/retropikzel/pffi/shared/array.scm index ed347d4..9d4bd7e 100644 --- a/retropikzel/pffi/shared/array.scm +++ b/retropikzel/pffi/shared/array.scm @@ -8,8 +8,8 @@ (define pffi-list->array (lambda (type list-arg) (let* ((array-size (length list-arg)) - (type-size (pffi-size-of type)) - (array (pffi-pointer-allocate (* type-size array-size))) + (type-size (c-size-of type)) + (array (make-c-bytevector (* type-size array-size))) (offset 0)) (for-each (lambda (item) @@ -25,7 +25,7 @@ (define pffi-array->list (lambda (array) (letrec* ((type (pffi-array-type array)) - (type-size (pffi-size-of type)) + (type-size (c-size-of type)) (max-offset (* type-size (pffi-array-size array))) (array-pointer (pffi-array-pointer array)) (looper (lambda (offset result) @@ -40,19 +40,19 @@ (define pffi-array-allocate (lambda (type size) - (array-make type size (pffi-pointer-allocate-calloc size (pffi-size-of type))))) + (array-make type size (pffi-pointer-allocate-calloc size (c-size-of type))))) (define pffi-array-get (lambda (array index) (let ((type (pffi-array-type array))) (pffi-pointer-get (pffi-array-pointer array) type - (* (pffi-size-of type) index))))) + (* (c-size-of type) index))))) (define pffi-array-set! (lambda (array index value) (let ((type (pffi-array-type array))) (pffi-pointer-set! (pffi-array-pointer array) type - (* (pffi-size-of type) index) + (* (c-size-of type) index) value)))) diff --git a/retropikzel/pffi/shared/main.scm b/retropikzel/pffi/shared/main.scm index 986ce39..fe8425d 100644 --- a/retropikzel/pffi/shared/main.scm +++ b/retropikzel/pffi/shared/main.scm @@ -1,4 +1,4 @@ -(cond-expand +#;(cond-expand (mosh (define pffi-init (lambda () #t))) (chicken (define-syntax pffi-init @@ -8,7 +8,7 @@ (chicken memory)) #t)))) (gambit #t) - (ypsilon + #;(ypsilon (define-syntax pffi-init (syntax-rules () ((_) @@ -22,37 +22,12 @@ #f #t))) -(define pffi-size-of +(define c-size-of (lambda (object) (cond ((pffi-struct? object) (pffi-struct-size object)) ((pffi-type? object) (size-of-type object)) (else (error "Not pffi-struct, pffi-enum of pffi-type" object))))) -(define pffi-string->pointer - (lambda (str) - (letrec* ((str-length (string-length str)) - (pointer (pffi-pointer-allocate (+ str-length 1))) - (looper (lambda (index) - (when (< index str-length) - (pffi-pointer-set! pointer - 'char - index - (string-ref str index)) - (looper (+ index 1)))))) - (looper 0) - (pffi-pointer-set! pointer 'char str-length #\null) - pointer))) - -(define pffi-pointer->string - (lambda (pointer) - (letrec* ((looper (lambda (index str) - (let ((c (pffi-pointer-get pointer 'char index))) - (if (char=? c #\null) - str - (looper (+ index 1) (cons c str))))))) - (list->string (reverse (looper 0 (list))))))) - - (define pffi-types '(int8 uint8 @@ -75,7 +50,7 @@ pointer void)) -(define string-split +(define pffi:string-split (lambda (str mark) (let* ((str-l (string->list str)) (res (list)) @@ -93,16 +68,11 @@ res))) (cond-expand - (gambit #t) - ((or chicken cyclone) - (define-syntax pffi-define-library - (syntax-rules () - ((_ scheme-name headers object-name options) - (begin - (define scheme-name #t) - (pffi-shared-object-load headers)))))) + (gambit #t) ; Defined in pffi/gambit.scm + (chicken #t) ; Defined in pffi/chicken.scm + (cyclone #t) ; Defined in pffi/cyclone.scm (else - (define-syntax pffi-define-library + (define-syntax define-c-library (syntax-rules () ((_ scheme-name headers object-name options) (define scheme-name @@ -125,7 +95,7 @@ (windows (append (if (get-environment-variable "PFFI_LOAD_PATH") - (string-split (get-environment-variable "PFFI_LOAD_PATH") #\;) + (pffi:string-split (get-environment-variable "PFFI_LOAD_PATH") #\;) (list)) (if (get-environment-variable "SYSTEM") (list (get-environment-variable "SYSTEM")) @@ -144,7 +114,7 @@ (list)) (list ".") (if (get-environment-variable "PATH") - (string-split (get-environment-variable "PATH") #\;) + (pffi:string-split (get-environment-variable "PATH") #\;) (list)) (if (get-environment-variable "PWD") (list (get-environment-variable "PWD")) @@ -152,7 +122,7 @@ (else (append (if (get-environment-variable "PFFI_LOAD_PATH") - (string-split (get-environment-variable "PFFI_LOAD_PATH") #\:) + (pffi:string-split (get-environment-variable "PFFI_LOAD_PATH") #\:) (list)) ; Guix (list (if (get-environment-variable "GUIX_ENVIRONMENT") @@ -161,7 +131,7 @@ "/run/current-system/profile/lib") ; Debian (if (get-environment-variable "LD_LIBRARY_PATH") - (string-split (get-environment-variable "LD_LIBRARY_PATH") #\:) + (pffi:string-split (get-environment-variable "LD_LIBRARY_PATH") #\:) (list)) (list ;;; x86-64 diff --git a/retropikzel/pffi/shared/pointer.scm b/retropikzel/pffi/shared/pointer.scm index 186f4b2..7b12f0e 100644 --- a/retropikzel/pffi/shared/pointer.scm +++ b/retropikzel/pffi/shared/pointer.scm @@ -1,75 +1,105 @@ (cond-expand - (windows (pffi-define-library pffi-libc-stdlib - '("stdlib.h") - "ucrtbase" - '((additional-versions ("0" "6"))))) - (else (pffi-define-library pffi-libc-stdlib - '("stdlib.h") - "c" - '((additional-versions ("0" "6")))))) + (windows (define-c-library libc + '("stdlib.h" "string.h") + "ucrtbase" + '((additional-versions ("0" "6"))))) + (else (define-c-library libc + '("stdlib.h" "string.h") + "c" + '((additional-versions ("0" "6")))))) -(cond-expand - (windows (pffi-define-library pffi-libc-stdio - '("stdio.h") - "ucrtbase" - '((additional-versions ("0" "6"))))) - (else (pffi-define-library pffi-libc-stdio - '("stdio") - "c" - '((additional-versions ("0" "6")))))) -;(pffi-define-function c-snprintf pffi-libc-stdio 'snprintf 'int '(pointer int pointer pointer)) -;(pffi-define-function c-strtol pffi-libc-stdio 'strtol 'uint64 '(pointer pointer int)) +(define-c-procedure c-strlen libc 'strlen 'int '(pointer)) +(define-c-procedure pffi-pointer-allocate-calloc libc 'calloc 'pointer '(int int)) +(define-c-procedure c-memset-address->pointer libc 'memset 'pointer '(uint64 uint8 int)) +(define-c-procedure c-memset-pointer->address libc 'memset 'uint64 '(pointer uint8 int)) +(define-c-procedure c-printf libc 'printf 'int '(pointer pointer)) +(define-c-procedure c-malloc libc 'malloc 'pointer '(int)) +(define-c-procedure c-strlen libc 'strlen 'int '(pointer)) (cond-expand (chibi #t) ; FIXME - (else (pffi-define-function pffi-pointer-allocate pffi-libc-stdlib 'malloc 'pointer '(int)))) + (else (define make-c-bytevector + (lambda (k . byte) + (if (null? byte) + (c-malloc k) + (bytevector->c-bytevector (make-bytevector k (car byte)))))))) -(pffi-define-function pffi-pointer-allocate-calloc pffi-libc-stdlib 'calloc 'pointer '(int int)) +(define c-bytevector + (lambda bytes + (bytevector->c-bytevector (apply bytevector bytes)))) (cond-expand (chibi #t) ; FIXME - (else (pffi-define-function pffi-pointer-free pffi-libc-stdlib 'free 'void '(pointer)))) + (else (define-c-procedure c-free libc 'free 'void '(pointer)))) -#;(define pffi-pointer-null - (lambda () - (let ((pointer (pffi-pointer-allocate (pffi-size-of 'pointer)))) - (pffi-pointer-set! pointer 'int 0 0) +(define bytevector->c-bytevector + (lambda (bytes) + (letrec* ((bytes-length (bytevector-length bytes)) + (pointer (make-c-bytevector bytes-length)) + (looper (lambda (index) + (when (< index bytes-length) + (pffi-pointer-set! pointer + 'uint8 + index + (bytevector-u8-ref bytes index)) + (looper (+ index 1)))))) + (looper 0) pointer))) -#;(define pffi-pointer-null? - (lambda (pointer) - (let ((address - (let ((str (pffi-pointer-allocate 512))) - (c-snprintf str 512 (pffi-string->pointer "%p") pointer) - (display "Scheme: p1 address: ") - (write (pffi-pointer->string str)) - (newline) - (display "Scheme: p1 address int: ") - (write (c-strtol str (pffi-pointer-null) 16)) - (newline) - (c-strtol str (pffi-pointer-null) 16)))) - (= address 0)))) +(define c-bytevector->bytevector + (lambda (pointer size) + (letrec* ((bytes (make-bytevector size)) + (looper (lambda (index) + (let ((byte (pffi-pointer-get pointer 'uint8 index))) + (if (= index size) + bytes + (begin + (bytevector-u8-set! bytes index byte) + (looper (+ index 1)))))))) + (looper 0)))) -#;(define pffi-pointer-address +(define c-bytevector-string-length + (lambda (bytevector) + (c-strlen bytevector))) + +(define c-bytevector->string (lambda (pointer) - (let* ((address-number - (let ((str (pffi-pointer-allocate 512))) - (c-snprintf str 512 (pffi-string->pointer "%p") pointer) - (display "Scheme: p1 address: ") - (write (pffi-pointer->string str)) - (newline) - (display "Scheme: p1 address int: ") - (write (c-strtol str (pffi-pointer-null) 16)) - (newline) - (c-strtol str (pffi-pointer-null) 16))) - (address (pffi-pointer-allocate (pffi-size-of 'uint64)))) - (display "Scheme: p2 address: ") - (write address) - (newline) - ;address-number - (pffi-pointer-set! address 'uint64 0 address-number) - ;address-number - ;(pffi-pointer-get address 'pointer 0) - address - ) - )) + (when (not (c-bytevector? pointer)) + (error "c-bytevector->string argument not c-bytevector" pointer)) + (let ((size (c-strlen pointer))) + (utf8->string (c-bytevector->bytevector pointer size))))) + +(define string->c-bytevector + (lambda (text) + (when (not (string? text)) + (error "string->bytevector argument not string" text)) + (bytevector->c-bytevector (string->utf8 (string-append text (string #\null)))))) + +(cond-expand + (kawa #t) ; FIXME + (chicken #t) ; FIXME + (else (define make-c-null + (lambda () + (cond-expand (stklos (let ((pointer (make-c-bytevector 1))) + (free-bytes pointer) + pointer)) + (else (c-memset-address->pointer 0 0 0))))))) + +(cond-expand + (kawa #t) ; FIXME + (chicken #t) ; FIXME + (else (define c-null? + (lambda (pointer) + (if (c-bytevector? pointer) + (= (c-memset-pointer->address pointer 0 0) 0) + #f))))) + +(define-syntax call-with-address-of-c-bytevector + (syntax-rules () + ((_ input-pointer thunk) + (let ((address-pointer (make-c-bytevector (c-size-of 'pointer)))) + (pffi-pointer-set! address-pointer 'pointer 0 input-pointer) + (apply thunk (list address-pointer)) + (set! input-pointer (pffi-pointer-get address-pointer 'pointer 0)) + (c-free address-pointer))))) + diff --git a/retropikzel/pffi/shared/struct.scm b/retropikzel/pffi/shared/struct.scm index 66c3786..926b9ee 100644 --- a/retropikzel/pffi/shared/struct.scm +++ b/retropikzel/pffi/shared/struct.scm @@ -15,33 +15,13 @@ (size (cdr (assoc 'size size-and-offsets))) (offsets (cdr (assoc 'offsets size-and-offsets))) (pointer (if (and (not (null? arguments)) - (pffi-pointer? (car arguments))) + (c-bytevector? (car arguments))) (car arguments) - (pffi-pointer-allocate size))) + (make-c-bytevector size))) (c-type-string (if (string? c-type) c-type (symbol->string c-type)))) (struct-make c-type-string size pointer offsets))))))) -#;(define pffi-struct-dereference - (lambda (struct) - (let ((pointer (pffi-pointer-allocate (pffi-struct-size struct))) - (offset 0)) - (for-each - (lambda (struct-member) - (let* ((member-type (cadr struct-member)) - (member-name (car struct-member)) - (member-size (pffi-size-of member-type))) - (pffi-pointer-set! pointer - member-type - offset - (pffi-struct-get struct member-name)) - (set! offset (+ offset member-size)))) - (pffi-struct-members struct)) - ;(pffi-pointer-get (pffi-struct-pointer struct) 'pointer 0) - ;(pffi-pointer-get pointer 'pointer 0) - pointer - ))) - -(define pffi-align-of +(define c-align-of (lambda (type) (cond-expand ;(guile (alignof (pffi-type->native-type type))) @@ -60,7 +40,7 @@ (offsets (map (lambda (member) (let* ((name (cdr member)) (type (car member)) - (type-alignment (pffi-align-of type))) + (type-alignment (c-align-of type))) (when (> (size-of-type type) largest-member-size) (set! largest-member-size (size-of-type type))) (if (or (= size 0) @@ -97,7 +77,7 @@ (let* ((size-and-offsets (calculate-struct-size-and-offsets members)) (size (cdr (assoc 'size size-and-offsets))) (offsets (cdr (assoc 'offsets size-and-offsets))) - (pointer (if (null? pointer) (pffi-pointer-allocate size) (car pointer))) + (pointer (if (null? pointer) (make-c-bytevector size) (car pointer))) (c-type (if (string? c-type) c-type (symbol->string c-type)))) (struct-make c-type size pointer offsets)))) diff --git a/retropikzel/pffi/shared/union.scm b/retropikzel/pffi/shared/union.scm deleted file mode 100644 index 93527f3..0000000 --- a/retropikzel/pffi/shared/union.scm +++ /dev/null @@ -1,8 +0,0 @@ - -(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/retropikzel/pffi/stklos.scm b/retropikzel/pffi/stklos.scm index 89ffe90..e9babd6 100644 --- a/retropikzel/pffi/stklos.scm +++ b/retropikzel/pffi/stklos.scm @@ -1,13 +1,13 @@ (define pffi-type->native-type (lambda (type) - (cond ((equal? type 'int8) :int) - ((equal? type 'uint8) :uint) - ((equal? type 'int16) :int) - ((equal? type 'uint16) :uint) + (cond ((equal? type 'int8) :char) + ((equal? type 'uint8) :char) + ((equal? type 'int16) :short) + ((equal? type 'uint16) :ushort) ((equal? type 'int32) :int) ((equal? type 'uint32) :uint) - ((equal? type 'int64) :int) - ((equal? type 'uint64) :uint) + ((equal? type 'int64) :long) + ((equal? type 'uint64) :ulong) ((equal? type 'char) :char) ((equal? type 'unsigned-char) :uchar) ((equal? type 'short) :short) @@ -19,21 +19,15 @@ ((equal? type 'float) :float) ((equal? type 'double) :double) ((equal? type 'pointer) :pointer) - ((equal? type 'string) :string) ((equal? type 'void) :void) ((equal? type 'struct) :void) (else (error "pffi-type->native-type -- No such pffi type" type))))) -(define pffi-pointer? +(define c-bytevector? (lambda (object) - (display "HERE: ") - (write object) - (newline) - (write (cpointer? object)) - (newline) (cpointer? object))) -(define-syntax pffi-define-function +(define-syntax define-c-procedure (syntax-rules () ((_ scheme-name shared-object c-name return-type argument-types) (begin @@ -76,53 +70,25 @@ ; FIXME (define size-of-type (lambda (type) - (cond - ((equal? type 'int8) 1) - ((equal? type 'uint8) 1) - ((equal? type 'int16) 2) - ((equal? type 'uint16) 2) - ((equal? type 'int32) 4) - ((equal? type 'uint32) 4) - ((equal? type 'int64) 8) - ((equal? type 'uint64) 8) - ((equal? type 'char) 1) - ((equal? type 'unsigned-char) 1) - ((equal? type 'short) 2) - ((equal? type 'unsigned-short) 2) - ((equal? type 'int) 4) - ((equal? type 'unsigned-int) 4) - ((equal? type 'long) 8) - ((equal? type 'unsigned-long) 8) - ((equal? type 'float) 4) - ((equal? type 'double) 8) - ((equal? type 'pointer) 8) - - ))) - -#;(define pffi-pointer-allocate - (lambda (size) - (allocate-bytes size))) - -;; FIXME -(define pffi-pointer-address - (lambda (pointer) - 0)) - -;; FIXME -(define pffi-pointer-null - (lambda () - (let ((p (allocate-bytes 0))) - (free-bytes p) - p))) - -#;(define pffi-pointer-free - (lambda (pointer) - (free-bytes pointer))) - -(define pffi-pointer-null? - (lambda (pointer) - (and (cpointer? pointer) - (cpointer-null? pointer)))) + (cond ((equal? type 'int8) 1) + ((equal? type 'uint8) 1) + ((equal? type 'int16) 2) + ((equal? type 'uint16) 2) + ((equal? type 'int32) 4) + ((equal? type 'uint32) 4) + ((equal? type 'int64) 8) + ((equal? type 'uint64) 8) + ((equal? type 'char) 1) + ((equal? type 'unsigned-char) 1) + ((equal? type 'short) 2) + ((equal? type 'unsigned-short) 2) + ((equal? type 'int) 4) + ((equal? type 'unsigned-int) 4) + ((equal? type 'long) 8) + ((equal? type 'unsigned-long) 8) + ((equal? type 'float) 4) + ((equal? type 'double) 8) + ((equal? type 'pointer) 8)))) (define pffi-pointer-set! (lambda (pointer type offset value) diff --git a/retropikzel/pffi/ypsilon.scm b/retropikzel/pffi/ypsilon.scm index 5dd9386..f59d640 100644 --- a/retropikzel/pffi/ypsilon.scm +++ b/retropikzel/pffi/ypsilon.scm @@ -25,52 +25,13 @@ ((eq? type 'void) 0) (else #f)))) -;(define c-malloc (c-function void* malloc (size_t))) -;(define c-free (c-function int free (void*))) - -#;(define pffi-pointer-allocate - (lambda (size) - (c-malloc size))) - -(define pffi-pointer-address - (lambda (pointer) - pointer)) - -(define pffi-pointer? +(define c-bytevector? (lambda (object) (number? object))) -#;(define pffi-pointer-free - (lambda (pointer) - (c-free pointer))) - -(define pffi-pointer-null - (lambda () - 0)) - -(define pffi-pointer-null? - (lambda (pointer) - (and (pffi-pointer? pointer) - (= (pffi-pointer-address pointer) 0)))) - -#;(define pffi-pointer->string - (lambda (pointer) - (c-string-ref pointer))) - -;(define c-memset(c-function int memset (void* int int))) -;(define c-snprintf (c-function int snprintf (void* size_t void*) (long double))) -#;(define pffi-string->pointer - (lambda (string-content) - (let* ((c-string (make-c-string string-content)) - (c-string-length (bytevector-length c-string)) - (pointer (c-malloc c-string-length))) - (c-memset pointer 0 c-string-length) - (c-snprintf pointer c-string-length (make-c-string "%s") c-string) - pointer))) - (define pffi-pointer-set! (lambda (pointer type offset value) - (let ((bv (make-bytevector-mapping (+ pointer offset) (pffi-size-of type)))) + (let ((bv (make-bytevector-mapping (+ pointer offset) (c-size-of type)))) (cond ((equal? type 'int8) (bytevector-c-int8-set! bv 0 value)) ((equal? type 'uint8) (bytevector-c-int8-set! bv 0 value)) ((equal? type 'int16) (bytevector-c-int16-set! bv 0 value)) @@ -93,7 +54,7 @@ (define pffi-pointer-get (lambda (pointer type offset) - (let ((bv (make-bytevector-mapping (+ pointer offset) (pffi-size-of type)))) + (let ((bv (make-bytevector-mapping (+ pointer offset) (c-size-of type)))) (cond ((equal? type 'int8) (bytevector-c-int8-ref bv 0)) ((equal? type 'uint8) (bytevector-c-uint8-ref bv 0)) ((equal? type 'int16) (bytevector-c-int16-ref bv 0)) @@ -115,44 +76,96 @@ ((equal? type 'pointer) (bytevector-c-void*-ref bv 0)))))) (define pffi-shared-object-load - (lambda (headers path options) + (lambda (path options) (load-shared-object path))) -(define-macro (pffi-type->native-type type) - `(cond ((equal? ,type int8) int8_t) - ((equal? ,type uint8) uint8_t) - ((equal? ,type int16) int16_t) - ((equal? ,type uint16) uint16_t) - ((equal? ,type int32) int32_t) - ((equal? ,type uint32) uint32_t) - ((equal? ,type int64) int64_t) - ((equal? ,type uint64) uint64_t) - ((equal? ,type char) char) - ((equal? ,type unsigned-char) char) - ((equal? ,type short) short) - ((equal? ,type unsigned-short) unsigned-short) - ((equal? ,type int) int) - ((equal? ,type unsigned-int) unsigned-int) - ((equal? ,type long) long) - ((equal? ,type unsigned-long) unsigned-long) - ((equal? ,type float) float) - ((equal? ,type double) double) - ((equal? ,type pointer) void*) - ((equal? ,type string) void*) - ((equal? ,type void) void) - ((equal? ,type callback) void*) - (else (error "pffi-type->native-type -- No such pffi type" ,type)))) +#;(define-macro + (pffi-type->native-type type) + `(cond ((equal? ,type 'int8) 'int8_t) + ((equal? ,type 'uint8) 'uint8_t) + ;((equal? ,type 'int16) 'int16_t) + ;((equal? ,type 'uint16) 'uint16_t) + ;((equal? ,type 'int32) 'int32_t) + ;((equal? ,type 'uint32) 'uint32_t) + ;((equal? ,type 'int64) 'int64_t) + ;((equal? ,type 'uint64) 'uint64_t) + ;((equal? ,type 'char) 'char) + ;((equal? ,type 'unsigned-char) 'char) + ;((equal? ,type 'short) 'short) + ;((equal? ,type 'unsigned-short) 'unsigned-short) + ((equal? ,type 'int) 'int) + ;((equal? ,type 'unsigned-int) 'unsigned-int) + ;((equal? ,type 'long) 'long) + ;((equal? ,type 'unsigned-long) 'unsigned-long) + ;((equal? ,type 'float) 'float) + ;((equal? ,type 'double) 'double) + ((equal? ,type 'pointer) 'void*) + ;((equal? ,type 'string) 'void*) + ((equal? ,type 'void) 'void) + ;((equal? ,type 'callback) 'void*) + (else (error "pffi-type->native-type -- No such pffi type" ,type)))) (define-macro - (pffi-define-function scheme-name shared-object c-name return-type argument-types) - `(define ,scheme-name - (c-function ,(pffi-type->native-type return-type) - ,(cadr c-name) - ,(map pffi-type->native-type (cdr argument-types))))) + (define-c-procedure scheme-name shared-object c-name return-type argument-types) + (begin + (let ((pffi-type->native-type + (lambda (type) + (cond ((equal? type 'int8) 'int8_t) + ((equal? type 'uint8) 'uint8_t) + ((equal? type 'int16) 'int16_t) + ((equal? type 'uint16) 'uint16_t) + ((equal? type 'int32) 'int32_t) + ((equal? type 'uint32) 'uint32_t) + ((equal? type 'int64) 'int64_t) + ((equal? type 'uint64) 'uint64_t) + ((equal? type 'char) 'char) + ((equal? type 'unsigned-char) 'char) + ((equal? type 'short) 'short) + ((equal? type 'unsigned-short) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'unsigned-int) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'unsigned-long) 'unsigned-long) + ((equal? type 'float) 'float) + ((equal? type 'double) 'double) + ((equal? type 'pointer) 'void*) + ((equal? type 'string) 'void*) + ((equal? type 'void) 'void) + ((equal? type 'callback) 'void*) + (else (error "pffi-type->native-type -- No such pffi type" type)))))) + `(define ,scheme-name + (c-function ,(pffi-type->native-type (cadr return-type)) + ,(cadr c-name) + ,(map pffi-type->native-type (cadr argument-types))))))) (define-macro (pffi-define-callback scheme-name return-type argument-types procedure) + (let ((pffi-type->native-type + (lambda (type) + (cond ((equal? type 'int8) 'int8_t) + ((equal? type 'uint8) 'uint8_t) + ((equal? type 'int16) 'int16_t) + ((equal? type 'uint16) 'uint16_t) + ((equal? type 'int32) 'int32_t) + ((equal? type 'uint32) 'uint32_t) + ((equal? type 'int64) 'int64_t) + ((equal? type 'uint64) 'uint64_t) + ((equal? type 'char) 'char) + ((equal? type 'unsigned-char) 'char) + ((equal? type 'short) 'short) + ((equal? type 'unsigned-short) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'unsigned-int) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'unsigned-long) 'unsigned-long) + ((equal? type 'float) 'float) + ((equal? type 'double) 'double) + ((equal? type 'pointer) 'void*) + ((equal? type 'string) 'void*) + ((equal? type 'void) 'void) + ((equal? type 'callback) 'void*) + (else (error "pffi-type->native-type -- No such pffi type" type)))))) `(define ,scheme-name (c-callback ,(pffi-type->native-type return-type) ,(map pffi-type->native-type (cdr argument-types)) - ,procedure))) + ,procedure)))) diff --git a/tests/compliance.scm b/tests/compliance.scm index f4ad12d..6604552 100755 --- a/tests/compliance.scm +++ b/tests/compliance.scm @@ -72,343 +72,343 @@ ;; pffi-init -(print-header 'pffi-init) +;(print-header 'pffi-init) -(pffi-init) +;(pffi-init) ;; pffi-type? -(print-header '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? '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) +;(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? '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-size-of +;; c-size-of -(print-header 'pffi-size-of) +(print-header 'c-size-of) -(define size-int8 (pffi-size-of 'int8)) +(define size-int8 (c-size-of 'int8)) (debug size-int8) (assert equal? (number? size-int8) #t) (assert = size-int8 1) -(define size-uint8 (pffi-size-of 'uint8)) +(define size-uint8 (c-size-of 'uint8)) (debug size-uint8) (assert equal? (number? size-uint8) #t) (assert = size-uint8 1) -(assert equal? (number? (pffi-size-of 'uint8)) #t) -(define size-int16 (pffi-size-of 'int16)) +(assert equal? (number? (c-size-of 'uint8)) #t) +(define size-int16 (c-size-of 'int16)) (debug size-int16) (assert equal? (number? size-int16) #t) (assert = size-int16 2) -(assert equal? (number? (pffi-size-of 'int16)) #t) -(define size-uint16 (pffi-size-of 'uint16)) +(assert equal? (number? (c-size-of 'int16)) #t) +(define size-uint16 (c-size-of 'uint16)) (debug size-uint16) (assert equal? (number? size-uint16) #t) (assert = size-uint16 2) -(assert equal? (number? (pffi-size-of 'uint16)) #t) -(define size-int32 (pffi-size-of 'int32)) +(assert equal? (number? (c-size-of 'uint16)) #t) +(define size-int32 (c-size-of 'int32)) (debug size-int32) (assert equal? (number? size-int32) #t) (assert = size-int32 4) -(assert equal? (number? (pffi-size-of 'int32)) #t) -(define size-uint32 (pffi-size-of 'uint32)) +(assert equal? (number? (c-size-of 'int32)) #t) +(define size-uint32 (c-size-of 'uint32)) (debug size-uint32) (assert equal? (number? size-uint32) #t) (assert = size-uint32 4) -(assert equal? (number? (pffi-size-of 'uint32)) #t) -(define size-int64 (pffi-size-of 'int64)) +(assert equal? (number? (c-size-of 'uint32)) #t) +(define size-int64 (c-size-of 'int64)) (debug size-int64) (assert equal? (number? size-int64) #t) (assert = size-int64 8) -(assert equal? (number? (pffi-size-of 'int64)) #t) -(define size-uint64 (pffi-size-of 'uint64)) +(assert equal? (number? (c-size-of 'int64)) #t) +(define size-uint64 (c-size-of 'uint64)) (debug size-uint64) (assert equal? (number? size-uint64) #t) (assert = size-uint64 8) -(assert equal? (number? (pffi-size-of 'uint64)) #t) -(define size-char (pffi-size-of 'char)) +(assert equal? (number? (c-size-of 'uint64)) #t) +(define size-char (c-size-of 'char)) (debug size-char) (assert equal? (number? size-char) #t) (assert = size-char 1) -(assert equal? (number? (pffi-size-of 'char)) #t) -(define size-unsigned-char (pffi-size-of 'unsigned-char)) +(assert equal? (number? (c-size-of 'char)) #t) +(define size-unsigned-char (c-size-of 'unsigned-char)) (debug size-unsigned-char) (assert equal? (number? size-unsigned-char) #t) (assert = size-unsigned-char 1) -(assert equal? (number? (pffi-size-of 'unsigned-char)) #t) -(define size-short (pffi-size-of 'short)) +(assert equal? (number? (c-size-of 'unsigned-char)) #t) +(define size-short (c-size-of 'short)) (debug size-short) (assert equal? (number? size-short) #t) (assert = size-short 2) -(assert equal? (number? (pffi-size-of 'short)) #t) -(define size-unsigned-short (pffi-size-of 'unsigned-short)) +(assert equal? (number? (c-size-of 'short)) #t) +(define size-unsigned-short (c-size-of 'unsigned-short)) (debug size-unsigned-short) (assert equal? (number? size-unsigned-short) #t) (assert = size-unsigned-short 2) -(assert equal? (number? (pffi-size-of 'unsigned-short)) #t) -(define size-int (pffi-size-of 'int)) +(assert equal? (number? (c-size-of 'unsigned-short)) #t) +(define size-int (c-size-of 'int)) (debug size-int) (assert equal? (number? size-int) #t) (assert = size-int 4) -(assert equal? (number? (pffi-size-of 'int)) #t) -(define size-unsigned-int (pffi-size-of 'unsigned-int)) +(assert equal? (number? (c-size-of 'int)) #t) +(define size-unsigned-int (c-size-of 'unsigned-int)) (debug size-unsigned-int) (assert equal? (number? size-unsigned-int) #t) (assert = size-unsigned-int 4) (cond-expand (i386 - (assert equal? (number? (pffi-size-of 'long)) #t) - (define size-long (pffi-size-of 'long)) + (assert equal? (number? (c-size-of 'long)) #t) + (define size-long (c-size-of 'long)) (debug size-long) (assert equal? (number? size-long) #t) (assert = size-long 4)) (else - (assert equal? (number? (pffi-size-of 'long)) #t) - (define size-long (pffi-size-of 'long)) + (assert equal? (number? (c-size-of 'long)) #t) + (define size-long (c-size-of 'long)) (debug size-long) (assert equal? (number? size-long) #t) (assert = size-long 8))) (cond-expand (i386 - (assert equal? (number? (pffi-size-of 'unsigned-long)) #t) - (define size-unsigned-long (pffi-size-of 'unsigned-long)) + (assert equal? (number? (c-size-of 'unsigned-long)) #t) + (define size-unsigned-long (c-size-of 'unsigned-long)) (debug size-unsigned-long) (assert equal? (number? size-unsigned-long) #t) (assert = size-unsigned-long 4)) (else - (assert equal? (number? (pffi-size-of 'long)) #t) - (define size-unsigned-long (pffi-size-of 'unsigned-long)) + (assert equal? (number? (c-size-of 'long)) #t) + (define size-unsigned-long (c-size-of 'unsigned-long)) (debug size-unsigned-long) (assert equal? (number? size-unsigned-long) #t) (assert = size-unsigned-long 8))) -(assert equal? (number? (pffi-size-of 'float)) #t) -(define size-float (pffi-size-of 'float)) +(assert equal? (number? (c-size-of 'float)) #t) +(define size-float (c-size-of 'float)) (debug size-float) (assert equal? (number? size-float) #t) (assert = size-float 4) -(assert equal? (number? (pffi-size-of 'double)) #t) -(define size-double (pffi-size-of 'double)) +(assert equal? (number? (c-size-of 'double)) #t) +(define size-double (c-size-of 'double)) (debug size-double) (assert equal? (number? size-double) #t) (assert = size-double 8) (cond-expand (i386 - (define size-pointer (pffi-size-of 'pointer)) + (define size-pointer (c-size-of 'pointer)) (debug size-pointer) (assert equal? (number? size-pointer) #t) (assert = size-pointer 4)) (else - (define size-pointer (pffi-size-of 'pointer)) + (define size-pointer (c-size-of 'pointer)) (debug size-pointer) (assert equal? (number? size-pointer) #t) (assert = size-pointer 8))) -;; pffi-align-of +;; c-align-of +; +;(print-header 'c-align-of) +; +;(define align-int8 (c-align-of 'int8)) +;(debug align-int8) +;(assert equal? (number? align-int8) #t) +;(assert = align-int8 1) +; +;(define align-uint8 (c-align-of 'uint8)) +;(debug align-uint8) +;(assert equal? (number? align-uint8) #t) +;(assert = align-uint8 1) +; +;(assert equal? (number? (c-align-of 'uint8)) #t) +;(define align-int16 (c-align-of 'int16)) +;(debug align-int16) +;(assert equal? (number? align-int16) #t) +;(assert = align-int16 2) +; +;(assert equal? (number? (c-align-of 'int16)) #t) +;(define align-uint16 (c-align-of 'uint16)) +;(debug align-uint16) +;(assert equal? (number? align-uint16) #t) +;(assert = align-uint16 2) +; +;(assert equal? (number? (c-align-of 'uint16)) #t) +;(define align-int32 (c-align-of 'int32)) +;(debug align-int32) +;(assert equal? (number? align-int32) #t) +;(assert = align-int32 4) +; +;(assert equal? (number? (c-align-of 'int32)) #t) +;(define align-uint32 (c-align-of 'uint32)) +;(debug align-uint32) +;(assert equal? (number? align-uint32) #t) +;(assert = align-uint32 4) +; +;(assert equal? (number? (c-align-of 'uint32)) #t) +;(define align-int64 (c-align-of 'int64)) +;(debug align-int64) +;(assert equal? (number? align-int64) #t) +;(assert = align-int64 8) +; +;(assert equal? (number? (c-align-of 'int64)) #t) +;(define align-uint64 (c-align-of 'uint64)) +;(debug align-uint64) +;(assert equal? (number? align-uint64) #t) +;(assert = align-uint64 8) +; +;(assert equal? (number? (c-align-of 'uint64)) #t) +;(define align-char (c-align-of 'char)) +;(debug align-char) +;(assert equal? (number? align-char) #t) +;(assert = align-char 1) +; +;(assert equal? (number? (c-align-of 'char)) #t) +;(define align-unsigned-char (c-align-of 'unsigned-char)) +;(debug align-unsigned-char) +;(assert equal? (number? align-unsigned-char) #t) +;(assert = align-unsigned-char 1) +; +;(assert equal? (number? (c-align-of 'unsigned-char)) #t) +;(define align-short (c-align-of 'short)) +;(debug align-short) +;(assert equal? (number? align-short) #t) +;(assert = align-short 2) +; +;(assert equal? (number? (c-align-of 'short)) #t) +;(define align-unsigned-short (c-align-of 'unsigned-short)) +;(debug align-unsigned-short) +;(assert equal? (number? align-unsigned-short) #t) +;(assert = align-unsigned-short 2) +; +;(assert equal? (number? (c-align-of 'unsigned-short)) #t) +;(define align-int (c-align-of 'int)) +;(debug align-int) +;(assert equal? (number? align-int) #t) +;(assert = align-int 4) +; +;(assert equal? (number? (c-align-of 'int)) #t) +;(define align-unsigned-int (c-align-of 'unsigned-int)) +;(debug align-unsigned-int) +;(assert equal? (number? align-unsigned-int) #t) +;(assert = align-unsigned-int 4) +; +;(cond-expand +; (i386 +; (assert equal? (number? (c-align-of 'long)) #t) +; (define align-long (c-align-of 'long)) +; (debug align-long) +; (assert equal? (number? align-long) #t) +; (assert = align-long 4)) +; (else +; (assert equal? (number? (c-align-of 'long)) #t) +; (define align-long (c-align-of 'long)) +; (debug align-long) +; (assert equal? (number? align-long) #t) +; (assert = align-long 8))) +; +;(cond-expand +; (i386 +; (assert equal? (number? (c-align-of 'unsigned-long)) #t) +; (define align-unsigned-long (c-align-of 'unsigned-long)) +; (debug align-unsigned-long) +; (assert equal? (number? align-unsigned-long) #t) +; (assert = align-unsigned-long 4)) +; (else +; (assert equal? (number? (c-align-of 'long)) #t) +; (define align-unsigned-long (c-align-of 'unsigned-long)) +; (debug align-unsigned-long) +; (assert equal? (number? align-unsigned-long) #t) +; (assert = align-unsigned-long 8))) +; +;(assert equal? (number? (c-align-of 'float)) #t) +;(define align-float (c-align-of 'float)) +;(debug align-float) +;(assert equal? (number? align-float) #t) +;(assert = align-float 4) +; +;(assert equal? (number? (c-align-of 'double)) #t) +;(define align-double (c-align-of 'double)) +;(debug align-double) +;(assert equal? (number? align-double) #t) +;(assert = align-double 8) +; +;(cond-expand +; (i386 +; (define align-pointer (c-align-of 'pointer)) +; (debug align-pointer) +; (assert equal? (number? align-pointer) #t) +; (assert = align-pointer 4)) +; (else +; (define align-pointer (c-align-of 'pointer)) +; (debug align-pointer) +; (assert equal? (number? align-pointer) #t) +; (assert = align-pointer 8))) -(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 - (i386 - (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 - (i386 - (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 - (i386 - (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-define-library +;; define-c-library (print-header 'pffi-define-library) (cond-expand - (windows (pffi-define-library libc-stdlib + (windows (define-c-library libc-stdlib '("stdlib.h") "ucrtbase" '((additional-versions ("0" "6"))))) - (else (pffi-define-library libc-stdlib + (else (define-c-library libc-stdlib '("stdlib.h") "c" '((additional-versions ("0" "6")))))) @@ -416,108 +416,146 @@ (debug libc-stdlib) (cond-expand - (windows (pffi-define-library libc-stdio + (windows (define-c-library libc-stdio '("stdio.h") "ucrtbase" '((additional-versions ("0" "6"))))) - (else (pffi-define-library libc-stdio + (else (define-c-library libc-stdio '("stdio.h") "c" '((additional-versions ("0" "6")))))) (debug libc-stdio) -(pffi-define-library c-testlib +(define-c-library c-testlib '("libtest.h") "test" '((additional-paths ("." "./tests")))) (debug c-testlib) -;; pffi-pointer-null +;; define-c-procedure -(print-header 'pffi-pointer-null) +(print-header 'define-c-procedure) -(define null-pointer (pffi-pointer-null)) +(define-c-procedure c-abs libc-stdlib 'abs 'int '(int)) +(debug c-abs) +(define absoluted (c-abs -2)) +(debug absoluted) +(assert = absoluted 2) + +(define-c-procedure c-puts libc-stdlib 'puts 'int '(pointer)) +(debug c-puts) +(define chars-written (c-puts (string->c-bytevector "puts: Hello from testing, I am C function puts"))) +(debug chars-written) +(assert = chars-written 47) + +(define-c-procedure c-atoi libc-stdlib 'atoi 'int '(pointer)) +(assert = (c-atoi (string->c-bytevector "100")) 100) + +(define-c-procedure c-fopen libc-stdio 'fopen 'pointer '(pointer pointer)) +(define output-file (c-fopen (string->c-bytevector "testfile.test") + (string->c-bytevector "w"))) +(debug output-file) +(define-c-procedure c-fprintf libc-stdio 'fprintf 'int '(pointer pointer)) +(define characters-written + (c-fprintf output-file (string->c-bytevector "Hello world"))) +(debug characters-written) +(assert equal? (= characters-written 11) #t) +(define-c-procedure c-fclose libc-stdio 'fclose 'int '(pointer)) +(define closed-status (c-fclose output-file)) +(debug closed-status) +(assert equal? (= closed-status 0) #t) +(assert equal? (file-exists? "testfile.test") #t) +(assert equal? (string=? (with-input-from-file "testfile.test" + (lambda () (read-line))) + "Hello world") #t) + +(define-c-procedure c-takes-no-args c-testlib 'takes_no_args 'void '()) +(debug c-takes-no-args) +(c-takes-no-args) + +(define-c-procedure c-takes-no-args-returns-int c-testlib 'takes_no_args_returns_int 'int '()) +(debug c-takes-no-args) +(define takes-no-args-returns-int-result (c-takes-no-args-returns-int)) +(assert equal? (= takes-no-args-returns-int-result 0) #t) + +;; c-bytevector? + +(print-header 'c-bytevector?) + +(define is-pointer (make-c-bytevector 100)) +(debug is-pointer) +(assert equal? (c-bytevector? is-pointer) #t) +;(assert equal? (c-bytevector? 100) #f) +(assert equal? (c-bytevector? 'bar) #f) + +;; make-c-null + +(print-header 'make-c-null) + +(define null-pointer (make-c-null)) (debug null-pointer) -(assert equal? (pffi-pointer-null? null-pointer) #t) +(assert equal? (c-null? null-pointer) #t) -;; pffi-pointer-null? +;; c-null? -(print-header 'pffi-pointer-null?) +(print-header 'c-null?) -(define is-null-pointer (pffi-pointer-null)) +(define is-null-pointer (make-c-null)) (debug is-null-pointer) -(assert equal? (pffi-pointer-null? is-null-pointer) #t) -(assert equal? (pffi-pointer-null? 100) #f) -(assert equal? (pffi-pointer-null? 'bar) #f) +(assert equal? (c-null? is-null-pointer) #t) +(assert equal? (c-null? 100) #f) +(assert equal? (c-null? 'bar) #f) -;; pffi-pointer-allocate +;;make-c-bytevector -(print-header 'pffi-pointer-allocate) +(print-header 'make-c-bytevector ) -(define test-pointer (pffi-pointer-allocate 100)) +(define test-pointer (make-c-bytevector 100)) (debug test-pointer) -(assert equal? (pffi-pointer? test-pointer) #t) -;(assert equal? (pffi-pointer? 0) #f) -;(assert equal? (pffi-pointer? #t) #f) -;(assert equal? (pffi-pointer? "Hello world") #f) -(assert equal? (pffi-pointer-null? test-pointer) #f) +(assert equal? (c-bytevector? test-pointer) #t) +;(assert equal? (c-bytevector? 0) #f) +;(assert equal? (c-bytevector? #t) #f) +;(assert equal? (c-bytevector? "Hello world") #f) +(assert equal? (c-null? test-pointer) #f) -;; pffi-pointer-address +;; call-with-address-of-c-bytevector -(print-header 'pffi-pointer-allocate) -(pffi-define-function test-passing-pointer-address +(print-header 'call-with-address-of-c-bytevector) + +(define-c-procedure test-passing-pointer-address c-testlib 'test_passing_pointer_address 'int '(pointer pointer)) -(pffi-define-function pa c-testlib 'pa 'pointer '(pointer)) -(pffi-define-function printa c-testlib 'printa 'void '(pointer)) -(define test-pointer1 (pffi-pointer-allocate 100)) -(debug test-pointer1) -(debug (pffi-pointer? test-pointer1)) -(assert equal? (pffi-pointer? test-pointer1) #t) -(debug (pffi-pointer-address test-pointer1)) - -(define input-pointer (pffi-pointer-allocate (pffi-size-of 'int))) +(define input-pointer (make-c-bytevector (c-size-of 'int))) (pffi-pointer-set! input-pointer 'int 0 100) -(define input-pointer-address (pffi-pointer-address input-pointer)) -(debug input-pointer-address) -(test-passing-pointer-address input-pointer input-pointer-address) -(debug input-pointer) -(debug input-pointer-address) (debug (pffi-pointer-get input-pointer 'int 0)) -;(assert equal? (pffi-pointer? input-pointer-address) #t) -;(assert equal? (= (pffi-pointer-get input-pointer 'int 0) 42) #t) -;(assert equal? (> (pffi-pointer-address test-pointer1) 0) #t) +(call-with-address-of-c-bytevector + input-pointer + (lambda (address) + (test-passing-pointer-address input-pointer address))) +(debug input-pointer) +(debug (pffi-pointer-get input-pointer 'int 0)) +(assert equal? (= (pffi-pointer-get input-pointer 'int 0) 42) #t) -;; pffi-pointer? +;; c-free -(print-header 'pffi-pointer?) +(print-header 'c-free) -(define is-pointer (pffi-pointer-allocate 100)) -(debug is-pointer) -(assert equal? (pffi-pointer? is-pointer) #t) -;(assert equal? (pffi-pointer? 100) #f) -(assert equal? (pffi-pointer? 'bar) #f) - -;; pffi-pointer-free - -(print-header 'pffi-pointer-free) - -(define pointer-to-be-freed (pffi-pointer-allocate 100)) +(define pointer-to-be-freed (make-c-bytevector 100)) (debug pointer-to-be-freed) -(pffi-pointer-free pointer-to-be-freed) +(c-free pointer-to-be-freed) (debug pointer-to-be-freed) ;; pffi-pointer-set! and pffi-pointer-get 1/2 (print-header "pffi-pointer-set! and pffi-pointer-get 1/2") -(define set-pointer (pffi-pointer-allocate 256)) +(define set-pointer (make-c-bytevector 256)) (define offset 64) (define value 1) (debug set-pointer) @@ -573,32 +611,32 @@ (pffi-define-struct test-struct1 'teststruct1 '((int . r) (int . g) (int . b))) (define struct1 (test-struct1)) (debug struct1) -(debug (pffi-size-of struct1)) -(assert = (pffi-size-of struct1) 12) +(debug (c-size-of struct1)) +(assert = (c-size-of struct1) 12) (pffi-define-struct test-struct2 'test2 '((int8 . r) (int8 . g) (int . b))) (define struct2 (test-struct2)) (debug struct2) -(debug (pffi-size-of struct2)) -(assert = (pffi-size-of struct2) 8) +(debug (c-size-of struct2)) +(assert = (c-size-of struct2) 8) (pffi-define-struct test-struct3 'test3 '((int8 . r) (int8 . g) (int . b))) (define struct3 (test-struct3)) (debug struct3) -(debug (pffi-size-of struct3)) -(assert = (pffi-size-of struct3) 8) +(debug (c-size-of struct3)) +(assert = (c-size-of struct3) 8) (pffi-define-struct test-struct4 'test4 '((int8 . r) (pointer . a) (int8 . g) (int . b))) (define struct4 (test-struct4)) (debug struct4) -(debug (pffi-size-of struct4)) -(assert = (pffi-size-of struct4) 24) +(debug (c-size-of struct4)) +(assert = (c-size-of struct4) 24) (pffi-define-struct test-struct5 'test5 '((int8 . r) (char . b) (pointer . a) (int8 . g) (int . b))) (define struct5 (test-struct5)) (debug struct5) -(debug (pffi-size-of struct5)) -(assert = (pffi-size-of struct5) 24) +(debug (c-size-of struct5)) +(assert = (c-size-of struct5) 24) (pffi-define-struct test-struct6 'test6 '((int8 . a) (char . b) @@ -616,18 +654,33 @@ (float . n))) (define struct6 (test-struct6)) (debug struct6) -(debug (pffi-size-of struct6)) -(assert = (pffi-size-of struct6) 96) +(debug (c-size-of struct6)) +(assert = (c-size-of struct6) 96) -;; pffi-string->pointer +;; bytevector->c-bytevector c-bytevector->bytevector -(print-header 'pffi-string->pointer) +(print-header "bytevector->c-bytevector c-bytevector->bytevector") -(define string-pointer (pffi-string->pointer "Hello world")) +(define bt1 (bytevector 1 2 3 4 5 6 7 8)) +(debug bt1) +(define btp1 (bytevector->c-bytevector bt1)) +(debug btp1) +(assert equal? (c-bytevector? btp1) #t) +(define bt2 (c-bytevector->bytevector btp1 (bytevector-length bt1))) +(debug bt2) +(assert equal? (bytevector? bt2) #t) +(debug (list bt1 bt2)) +(assert equal? bt1 bt2) + +;; string->c-bytevector + +(print-header 'string->c-bytevector) + +(define string-pointer (string->c-bytevector "Hello world")) (debug string-pointer) -(debug (pffi-pointer->string string-pointer)) -(assert equal? (pffi-pointer? string-pointer) #t) -(assert equal? (pffi-pointer-null? string-pointer) #f) +(debug (c-bytevector->string string-pointer)) +(assert equal? (c-bytevector? string-pointer) #t) +(assert equal? (c-null? string-pointer) #f) (debug (pffi-pointer-get string-pointer 'char 0)) (assert char=? (pffi-pointer-get string-pointer 'char 0) #\H) (debug (pffi-pointer-get string-pointer 'char 1)) @@ -641,28 +694,28 @@ (debug (pffi-pointer-get string-pointer 'char 10)) (assert char=? (pffi-pointer-get string-pointer 'char 10) #\d) -;; pffi-pointer->string +;; c-bytevector->string -(print-header 'pffi-pointer->string) +(print-header 'c-bytevector->string) -(define pointer-string (pffi-pointer->string string-pointer)) +(define pointer-string (c-bytevector->string string-pointer)) (debug pointer-string) (assert equal? (string? pointer-string) #t) (assert string=? pointer-string "Hello world") -(assert string=? (pffi-pointer->string (pffi-string->pointer "https://scheme.org")) "https://scheme.org") +(assert string=? (c-bytevector->string (string->c-bytevector "https://scheme.org")) "https://scheme.org") (define test-url-string "https://scheme.org") (debug test-url-string) -(define test-url (pffi-string->pointer test-url-string)) +(define test-url (string->c-bytevector test-url-string)) (debug test-url) -(debug (pffi-pointer->string test-url)) -(assert equal? (string=? (pffi-pointer->string test-url) test-url-string) #t) +(debug (c-bytevector->string test-url)) +(assert equal? (string=? (c-bytevector->string test-url) test-url-string) #t) ;; pffi-pointer-get (print-header "pffi-pointer-get") (define hello-string "hello") -(define hello-string-pointer (pffi-string->pointer hello-string)) +(define hello-string-pointer (string->c-bytevector hello-string)) (debug (pffi-pointer-get hello-string-pointer 'char 0)) (assert char=? (pffi-pointer-get hello-string-pointer 'char 0) #\h) @@ -675,81 +728,36 @@ (print-header "pffi-pointer-set! and pffi-pointer-get 2/2") -(define pointer-to-be-set (pffi-string->pointer "FOOBAR")) +(define pointer-to-be-set (string->c-bytevector "FOOBAR")) (debug pointer-to-be-set) -(debug (pffi-pointer->string pointer-to-be-set)) +(debug (c-bytevector->string pointer-to-be-set)) (pffi-pointer-set! set-pointer 'pointer offset pointer-to-be-set) (debug (pffi-pointer-get set-pointer 'pointer offset)) (assert equal? - (pffi-pointer? (pffi-pointer-get set-pointer 'pointer offset)) + (c-bytevector? (pffi-pointer-get set-pointer 'pointer offset)) #t) -(debug (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset))) +(debug (c-bytevector->string (pffi-pointer-get set-pointer 'pointer offset))) (assert equal? - (string? (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset))) + (string? (c-bytevector->string (pffi-pointer-get set-pointer 'pointer offset))) #t) -(debug (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset))) +(debug (c-bytevector->string (pffi-pointer-get set-pointer 'pointer offset))) (assert equal? - (string=? (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset)) "FOOBAR") + (string=? (c-bytevector->string (pffi-pointer-get set-pointer 'pointer offset)) "FOOBAR") #t) (define string-to-be-set "FOOBAR") (debug string-to-be-set) -(pffi-pointer-set! set-pointer 'pointer offset (pffi-string->pointer string-to-be-set)) -(assert string=? (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset)) "FOOBAR") +(pffi-pointer-set! set-pointer 'pointer offset (string->c-bytevector string-to-be-set)) +(assert string=? (c-bytevector->string (pffi-pointer-get set-pointer 'pointer offset)) "FOOBAR") -;; pffi-define - -(print-header 'pffi-define) - -(pffi-define-function c-abs libc-stdlib 'abs 'int '(int)) -(debug c-abs) -(define absoluted (c-abs -2)) -(debug absoluted) -(assert = absoluted 2) - -(pffi-define-function c-puts libc-stdlib 'puts 'int '(pointer)) -(debug c-puts) -(define chars-written (c-puts (pffi-string->pointer "puts: Hello from testing, I am C function puts"))) -(debug chars-written) -(assert = chars-written 47) - -(pffi-define-function c-atoi libc-stdlib 'atoi 'int '(pointer)) -(assert = (c-atoi (pffi-string->pointer "100")) 100) - -(pffi-define-function c-fopen libc-stdio 'fopen 'pointer '(pointer pointer)) -(define output-file (c-fopen (pffi-string->pointer "testfile.test") - (pffi-string->pointer "w"))) -(debug output-file) -(pffi-define-function c-fprintf libc-stdio 'fprintf 'int '(pointer pointer)) -(define characters-written - (c-fprintf output-file (pffi-string->pointer "Hello world"))) -(debug characters-written) -(assert equal? (= characters-written 11) #t) -(pffi-define-function c-fclose libc-stdio 'fclose 'int '(pointer)) -(define closed-status (c-fclose output-file)) -(debug closed-status) -(assert equal? (= closed-status 0) #t) -(assert equal? (file-exists? "testfile.test") #t) -(assert equal? (string=? (with-input-from-file "testfile.test" - (lambda () (read-line))) - "Hello world") #t) - -(pffi-define-function c-takes-no-args c-testlib 'takes_no_args 'void '()) -(debug c-takes-no-args) -(c-takes-no-args) - -(pffi-define-function c-takes-no-args-returns-int c-testlib 'takes_no_args_returns_int 'int '()) -(debug c-takes-no-args) -(define takes-no-args-returns-int-result (c-takes-no-args-returns-int)) -(assert equal? (= takes-no-args-returns-int-result 0) #t) ;; pffi-struct-get (print-header 'pffi-struct-get) -(pffi-define-function c-init-struct c-testlib 'init_struct 'pointer '(pointer)) -(pffi-define-function c-check-offset c-testlib 'check_offset 'void '(int int)) +(define-c-procedure c-init-struct c-testlib 'init_struct 'pointer '(pointer)) +(define-c-procedure c-check-offset c-testlib 'check_offset 'void '(int int)) (pffi-define-struct struct-test-get1 'test_get1 '((int8 . a) (char . b) @@ -793,18 +801,18 @@ (debug (pffi-struct-get struct-test 'd)) (assert char=? (pffi-struct-get struct-test 'd) #\d) (debug (pffi-struct-get struct-test 'e)) -(debug (pffi-pointer-null? (pffi-struct-get struct-test 'e))) -(assert equal? (pffi-pointer-null? (pffi-struct-get struct-test 'e)) #t) +(debug (c-null? (pffi-struct-get struct-test 'e))) +(assert equal? (c-null? (pffi-struct-get struct-test 'e)) #t) (debug (pffi-struct-get struct-test 'f)) (assert = (pffi-struct-get struct-test 'f) 6.0) (debug (pffi-struct-get struct-test 'g)) -(debug (pffi-pointer->string (pffi-struct-get struct-test 'g))) -(assert equal? (string=? (pffi-pointer->string (pffi-struct-get struct-test 'g)) "FOOBAR") #t) +(debug (c-bytevector->string (pffi-struct-get struct-test 'g))) +(assert equal? (string=? (c-bytevector->string (pffi-struct-get struct-test 'g)) "FOOBAR") #t) (debug (pffi-struct-get struct-test 'h)) (assert = (pffi-struct-get struct-test 'h) 8) (debug (pffi-struct-get struct-test 'i)) -(debug (pffi-pointer-null? (pffi-struct-get struct-test 'i))) -(assert equal? (pffi-pointer-null? (pffi-struct-get struct-test 'i)) #t) +(debug (c-null? (pffi-struct-get struct-test 'i))) +(assert equal? (c-null? (pffi-struct-get struct-test 'i)) #t) (debug (pffi-struct-get struct-test 'j)) (assert = (pffi-struct-get struct-test 'j) 10) (debug (pffi-struct-get struct-test 'k)) @@ -820,7 +828,7 @@ (print-header "pffi-struct-set! 1") -(pffi-define-function c-test-check c-testlib 'test_check 'int '(pointer)) +(define-c-procedure c-test-check c-testlib 'test_check 'int '(pointer)) (pffi-define-struct struct-test-set1 'test_set1 '((int8 . a) (char . b) @@ -841,11 +849,11 @@ (pffi-struct-set! struct-test1 'b #\b) (pffi-struct-set! struct-test1 'c 3.0) (pffi-struct-set! struct-test1 'd #\d) -(pffi-struct-set! struct-test1 'e (pffi-pointer-null)) +(pffi-struct-set! struct-test1 'e (make-c-null)) (pffi-struct-set! struct-test1 'f 6.0) -(pffi-struct-set! struct-test1 'g (pffi-string->pointer "foo")) +(pffi-struct-set! struct-test1 'g (string->c-bytevector "foo")) (pffi-struct-set! struct-test1 'h 8) -(pffi-struct-set! struct-test1 'i (pffi-pointer-null)) +(pffi-struct-set! struct-test1 'i (make-c-null)) (pffi-struct-set! struct-test1 'j 10) (pffi-struct-set! struct-test1 'k 11) (pffi-struct-set! struct-test1 'l 12) @@ -857,7 +865,7 @@ ;(print-header "pffi-struct constructor with pointer") -;(pffi-define-function c-test-new c-testlib 'test_new 'pointer '()) +;(define-c-procedure c-test-new c-testlib 'test_new 'pointer '()) ;(define struct-test2-pointer (c-test-new)) #;(define struct-test2 (pffi-struct-make 'test '((int8 . a) @@ -888,17 +896,17 @@ ;(debug (pffi-struct-get struct-test2 'd)) ;(assert char=? (pffi-struct-get struct-test2 'd) #\d) ;(debug (pffi-struct-get struct-test2 'e)) -;(debug (pffi-pointer-null? (pffi-struct-get struct-test2 'e))) -;(assert equal? (pffi-pointer-null? (pffi-struct-get struct-test2 'e)) #t) +;(debug (c-null? (pffi-struct-get struct-test2 'e))) +;(assert equal? (c-null? (pffi-struct-get struct-test2 'e)) #t) ;(debug (pffi-struct-get struct-test2 'f)) ;(assert = (pffi-struct-get struct-test2 'f) 6.0) -;(debug (pffi-pointer->string (pffi-struct-get struct-test2 'g))) -;(assert equal? (string=? (pffi-pointer->string (pffi-struct-get struct-test2 'g)) "FOOBAR") #t) +;(debug (c-bytevector->string (pffi-struct-get struct-test2 'g))) +;(assert equal? (string=? (c-bytevector->string (pffi-struct-get struct-test2 'g)) "FOOBAR") #t) ;(debug (pffi-struct-get struct-test2 'h)) ;(assert = (pffi-struct-get struct-test2 'h) 8) ;(debug (pffi-struct-get struct-test2 'i)) -;(debug (pffi-pointer-null? (pffi-struct-get struct-test2 'i))) -;(assert (lambda (p t) (pffi-pointer-null? p)) (pffi-struct-get struct-test2 'i) #t) +;(debug (c-null? (pffi-struct-get struct-test2 'i))) +;(assert (lambda (p t) (c-null? p)) (pffi-struct-get struct-test2 'i) #t) ;(debug (pffi-struct-get struct-test2 'j)) ;(assert = (pffi-struct-get struct-test2 'j) 10) ;(debug (pffi-struct-get struct-test2 'k)) @@ -919,10 +927,10 @@ (debug (pffi-list->array 'int test-list1)) (assert equal? (pffi-array->list (pffi-list->array 'int test-list1)) test-list1) -(define test-array1 (pffi-pointer-allocate (* (pffi-size-of 'int) 3))) -(pffi-pointer-set! test-array1 'int (* (pffi-size-of 'int) 0) 4) -(pffi-pointer-set! test-array1 'int (* (pffi-size-of 'int) 1) 5) -(pffi-pointer-set! test-array1 'int (* (pffi-size-of 'int) 2) 6) +(define test-array1 (make-c-bytevector (* (c-size-of 'int) 3))) +(pffi-pointer-set! test-array1 'int (* (c-size-of 'int) 0) 4) +(pffi-pointer-set! test-array1 'int (* (c-size-of 'int) 1) 5) +(pffi-pointer-set! test-array1 'int (* (c-size-of 'int) 2) 6) (debug test-array1) (debug (pffi-array->list (pffi-pointer->array test-array1 'int 3))) (define check-list1 (list 4 5 6)) @@ -941,7 +949,7 @@ ;; pffi-struct-dereference 1 ;(print-header "pffi-struct-dereference 1") -;(pffi-define-function c-color-check-by-value c-testlib 'color_check_by_value 'int '((struct . color))) +;(define-c-procedure c-color-check-by-value c-testlib 'color_check_by_value 'int '((struct . color))) #;(pffi-define-struct make-struct-color 'color '((int8 . r) (int8 . g) (int8 . b) @@ -957,7 +965,7 @@ ;(print-header "pffi-struct-dereference 2") -;(pffi-define-function c-test-check-by-value c-testlib 'test_check_by_value 'int '((struct . test))) +;(define-c-procedure c-test-check-by-value c-testlib 'test_check_by_value 'int '((struct . test))) #;(pffi-define-struct make-struct-test-dereference2 'test '((int8 . a) @@ -979,11 +987,11 @@ ;(debug (pffi-struct-set! struct-test3 'b #\b)) ;(debug (pffi-struct-set! struct-test3 'c 3.0)) ;(debug (pffi-struct-set! struct-test3 'd #\d)) -;(debug (pffi-struct-set! struct-test3 'e (pffi-pointer-null))) +;(debug (pffi-struct-set! struct-test3 'e (make-c-null))) ;(debug (pffi-struct-set! struct-test3 'f 6.0)) -;(debug (pffi-struct-set! struct-test3 'g (pffi-string->pointer "foo"))) +;(debug (pffi-struct-set! struct-test3 'g (string->c-bytevector "foo"))) ;(debug (pffi-struct-set! struct-test3 'h 8)) -;(debug (pffi-struct-set! struct-test3 'i (pffi-pointer-null))) +;(debug (pffi-struct-set! struct-test3 'i (make-c-null))) ;(debug (pffi-struct-set! struct-test3 'j 10)) ;(debug (pffi-struct-set! struct-test3 'k 11)) ;(debug (pffi-struct-set! struct-test3 'l 12)) @@ -1009,12 +1017,12 @@ ;(print-header 'pffi-define-callback) -;(define array (pffi-pointer-allocate (* (pffi-size-of 'int) 3))) -;(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 0) 3) -;(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 1) 2) -;(pffi-pointer-set! array 'int (* (pffi-size-of 'int) 2) 1) +;(define array (make-c-bytevector (* (c-size-of 'int) 3))) +;(pffi-pointer-set! array 'int (* (c-size-of 'int) 0) 3) +;(pffi-pointer-set! array 'int (* (c-size-of 'int) 1) 2) +;(pffi-pointer-set! array 'int (* (c-size-of 'int) 2) 1) -;(pffi-define-function qsort libc-stdlib 'qsort 'void '(pointer int int callback)) +;(define-c-procedure qsort libc-stdlib 'qsort 'void '(pointer int int callback)) #;(pffi-define-callback compare 'int @@ -1028,17 +1036,17 @@ ;(write compare) ;(newline) -#;(define unsorted (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0)) - (pffi-pointer-get array 'int (* (pffi-size-of 'int) 1)) - (pffi-pointer-get array 'int (* (pffi-size-of 'int) 2)))) +#;(define unsorted (list (pffi-pointer-get array 'int (* (c-size-of 'int) 0)) + (pffi-pointer-get array 'int (* (c-size-of 'int) 1)) + (pffi-pointer-get array 'int (* (c-size-of 'int) 2)))) ;(debug unsorted) ;(assert equal? unsorted (list 3 2 1)) -;(qsort array 3 (pffi-size-of 'int) compare) +;(qsort array 3 (c-size-of 'int) compare) -#;(define sorted (list (pffi-pointer-get array 'int (* (pffi-size-of 'int) 0)) - (pffi-pointer-get array 'int (* (pffi-size-of 'int) 1)) - (pffi-pointer-get array 'int (* (pffi-size-of 'int) 2)))) +#;(define sorted (list (pffi-pointer-get array 'int (* (c-size-of 'int) 0)) + (pffi-pointer-get array 'int (* (c-size-of 'int) 1)) + (pffi-pointer-get array 'int (* (c-size-of 'int) 2)))) ;(debug sorted) ;(assert equal? sorted (list 1 2 3))