diff --git a/retropikzel/pffi.sld b/retropikzel/pffi.sld index 1333eaa..de89713 100644 --- a/retropikzel/pffi.sld +++ b/retropikzel/pffi.sld @@ -31,7 +31,7 @@ pffi-struct-set! pffi-define pffi-define-callback - scheme-procedure-to-pointer + ;scheme-procedure-to-pointer ) (include-shared "pffi/chibi-pffi")) (chicken-5 @@ -66,8 +66,7 @@ pffi-struct-get pffi-struct-set! pffi-define - ;pffi-define-callback - )) + pffi-define-callback)) (chicken6 (import (scheme base) (scheme write) @@ -404,8 +403,7 @@ pffi-struct-get pffi-struct-set! pffi-define - ;pffi-define-callback - )) + pffi-define-callback)) (skint (import (scheme base) (scheme write) @@ -544,5 +542,7 @@ (tr7 (include "pffi/tr7.scm")) (ypsilon (include "pffi/ypsilon.scm"))) ;(include "pffi/shared/union.scm") + (include "pffi/shared/main.scm") + (include "pffi/shared/pointer.scm") (include "pffi/shared/struct.scm") - (include "pffi/shared/main.scm")) + ) diff --git a/retropikzel/pffi/chibi.scm b/retropikzel/pffi/chibi.scm index 890bed5..bbc201c 100644 --- a/retropikzel/pffi/chibi.scm +++ b/retropikzel/pffi/chibi.scm @@ -46,7 +46,7 @@ (or (equal? object #f) ; False can be null pointer (pointer? object)))) -(define pffi-pointer-allocate +#;(define pffi-pointer-allocate (lambda (size) (pointer-allocate size))) @@ -54,7 +54,7 @@ (lambda (pointer) (pointer-address pointer))) -(define pffi-pointer-free +#;(define pffi-pointer-free (lambda (pointer) (pointer-free pointer))) diff --git a/retropikzel/pffi/chibi/pffi.stub b/retropikzel/pffi/chibi/pffi.stub index 3196990..8b187a2 100644 --- a/retropikzel/pffi/chibi/pffi.stub +++ b/retropikzel/pffi/chibi/pffi.stub @@ -272,8 +272,9 @@ (c-declare "void* scheme_procedure_to_pointer(sexp proc) { if(sexp_procedurep(proc) == 1) { - sexp debug1 = sexp_procedure_code(proc); - printf(\"HERE: %u\\n\", sexp_bytecode_length(debug1)); + return 0; //&sexp_unbox_fixnum(proc); + } else { + printf(\"NOT A FUNCTION\\n\"); } return (void*)proc; }") diff --git a/retropikzel/pffi/chicken5.scm b/retropikzel/pffi/chicken5.scm index 05bfa22..082d349 100644 --- a/retropikzel/pffi/chicken5.scm +++ b/retropikzel/pffi/chicken5.scm @@ -67,14 +67,10 @@ `(define ,scheme-name (foreign-safe-lambda ,return-type ,c-name ,@ argument-types))))))) -#;(define-syntax pffi-define-callback +(define-syntax pffi-define-callback (er-macro-transformer (lambda (expr rename compare) - (let* ((debug (begin - (write (list-ref expr 4)) - (newline) - )) - (pffi-type->native-type ; Chicken has this procedure in three places + (let* ((pffi-type->native-type ; Chicken has this procedure in three places (lambda (type) (cond ((equal? type 'int8) 'byte) ((equal? type 'uint8) 'unsigned-byte) @@ -107,7 +103,7 @@ (lambda (name type) `(,name ,type)) argument-types argument-names)) - (procedure-body (cadr (cdr (list-ref expr 4))))) + (procedure-body (cdr (cdr (list-ref expr 4))))) `(begin (define-external ,(cons 'external_123456789 arguments) ,return-type (begin ,@ procedure-body)) @@ -137,7 +133,7 @@ ((equal? type 'string) (foreign-value "sizeof(void*)" int)) ((equal? type 'callback) (foreign-value "sizeof(void*)" int))))) -(define pffi-pointer-allocate +#;(define pffi-pointer-allocate (lambda (size) (allocate size))) @@ -186,7 +182,7 @@ `(foreign-declare ,(string-append "#include <" header ">"))) headers)))))) -(define pffi-pointer-free +#;(define pffi-pointer-free (lambda (pointer) (if (not (pointer? pointer)) (error "pffi-pointer-free -- Argument is not pointer" pointer)) diff --git a/retropikzel/pffi/cyclone.scm b/retropikzel/pffi/cyclone.scm index 83824ee..5390da7 100644 --- a/retropikzel/pffi/cyclone.scm +++ b/retropikzel/pffi/cyclone.scm @@ -93,7 +93,7 @@ ((equal? type 'double) (c-value "sizeof(double)" int)) ((equal? type 'pointer) (c-value "sizeof(void*)" int))))) -(define-c pffi-pointer-allocate +#;(define-c pffi-pointer-allocate "(void *data, int argc, closure _, object k, object size)" "make_c_opaque(opq, malloc(obj_obj2int(size))); return_closcall1(data, k, &opq);") @@ -121,7 +121,7 @@ `(include-c-header ,(string-append "<" header ">"))) (cdr (car (cdr expr)))))))) -(define-c pffi-pointer-free +#;(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));") diff --git a/retropikzel/pffi/gambit.scm b/retropikzel/pffi/gambit.scm index 1c331d8..e91ebec 100644 --- a/retropikzel/pffi/gambit.scm +++ b/retropikzel/pffi/gambit.scm @@ -58,7 +58,7 @@ (map (lambda (header) (string-append "#include <" header ">" (string #\newline))) - (cdr headers)))))) + header-list))))) (define pointer? (c-lambda ((pointer void)) bool "___return(1);")) (define pffi-pointer? @@ -77,11 +77,11 @@ (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-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 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;")) diff --git a/retropikzel/pffi/gauche.scm b/retropikzel/pffi/gauche.scm index 687fa17..052bb69 100644 --- a/retropikzel/pffi/gauche.scm +++ b/retropikzel/pffi/gauche.scm @@ -113,14 +113,6 @@ ((equal? type 'void) (pointer-get-pointer pointer offset)) ((equal? type 'pointer) (pointer-get-pointer pointer offset))))) -#;(define pffi-string->pointer - (lambda (string-content) - (string->pointer string-content))) - -#;(define pffi-pointer->string - (lambda (pointer) - (pointer->string pointer))) - (define pffi-type->libffi-type (lambda (type) (cond ((equal? type 'int8) (get-ffi-type-int8)) @@ -185,3 +177,12 @@ 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 () + ((pffi-define scheme-name return-type argument-types procedure) + (define scheme-name + (make-c-callback return-type 'argument-types procedure))))) diff --git a/retropikzel/pffi/gauche/gauchelib.scm b/retropikzel/pffi/gauche/gauchelib.scm index e32a8ac..4d5c212 100644 --- a/retropikzel/pffi/gauche/gauchelib.scm +++ b/retropikzel/pffi/gauche/gauchelib.scm @@ -96,4 +96,5 @@ (define-cproc get-ffi-type-float () get_ffi_type_float) (define-cproc get-ffi-type-double () get_ffi_type_double) (define-cproc get-ffi-type-pointer () get_ffi_type_pointer) - ) + + (define-cproc procedure-to-pointer (procedure) procedure_to_pointer)) diff --git a/retropikzel/pffi/kawa.scm b/retropikzel/pffi/kawa.scm index ba4561b..350179c 100644 --- a/retropikzel/pffi/kawa.scm +++ b/retropikzel/pffi/kawa.scm @@ -131,7 +131,7 @@ (invoke native-type 'byteAlignment) #f)))) -(define pffi-pointer-allocate +#;(define pffi-pointer-allocate (lambda (size) (invoke (invoke arena 'allocate size 1) 'reinterpret size))) @@ -154,7 +154,7 @@ (invoke (invoke pointer 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) 'getString 0))) (define pffi-shared-object-load - (lambda (header path . options) + (lambda (path options) (let* ((library-file (make java.io.File path)) (file-name (invoke library-file 'getName)) (library-parent-folder (make java.io.File (invoke library-file 'getParent))) @@ -169,7 +169,7 @@ (list (cons 'linker linker) (cons 'lookup lookup))))) -(define pffi-pointer-free +#;(define pffi-pointer-free (lambda (pointer) #t)) diff --git a/retropikzel/pffi/larceny-util.scm b/retropikzel/pffi/larceny-util.scm new file mode 100644 index 0000000..8228fac --- /dev/null +++ b/retropikzel/pffi/larceny-util.scm @@ -0,0 +1,88 @@ +;; Copied from Larceny source +;; Copyright 1998 Lars T Hansen. +;; Copied code begins + +(define %set32u) + +; %peek* and %poke*: convenient access to values in memory. + +(define (%peek8 addr) + (let ((x (make-bytevector 1))) + (peek-bytes addr x 1) + (let ((v (bytevector-ref x 0))) + (if (> v 127) + (- (- 256 v)) + v)))) + +(define (%peek16 addr) + (let ((x (make-bytevector 2))) + (peek-bytes addr x 2) + (%get16 x 0))) + +(define (%peek32 addr) + (let ((x (make-bytevector 4))) + (peek-bytes addr x 4) + (%get32 x 0))) + +(define (%peek8u addr) + (let ((x (make-bytevector 1))) + (peek-bytes addr x 1) + (bytevector-ref x 0))) + +(define (%peek16u addr) + (let ((x (make-bytevector 2))) + (peek-bytes addr x 2) + (%get16u x 0))) + +(define (%peek32u addr) + (let ((x (make-bytevector 4))) + (peek-bytes addr x 4) + (%get32u x 0))) + +(define (%poke8 addr val) + (let ((x (make-bytevector 1))) + (if (< val 0) + (bytevector-set! x 0 (+ 256 val)) + (bytevector-set! x 0 val)) + (poke-bytes addr x 1))) + +(define (%poke16 addr val) + (let ((x (make-bytevector 2))) + (%set16 x 0 val) + (poke-bytes addr x 2))) + +(define (%poke32 addr val) + (let ((x (make-bytevector 4))) + (%set32 x 0 val) + (poke-bytes addr x 4))) + +(define (%poke8u addr val) + (let ((x (make-bytevector 1))) + (bytevector-set! x 0 val) + (poke-bytes addr x 1))) + +(define (%poke16u addr val) + (let ((x (make-bytevector 2))) + (%set16u x 0 val) + (poke-bytes addr x 2))) + +(define (%poke32u addr val) + (let ((x (make-bytevector 4))) + (%set32u x 0 val) + (poke-bytes addr x 4))) + +(define %peek-int %peek32) +(define %peek-long %peek32) +(define %peek-uint %peek32u) +(define %peek-ulong %peek32u) +(define %peek-short %peek16) +(define %peek-ushort %peek16u) +(define %peek-pointer %peek32u) + +(define %poke-int %poke32) +(define %poke-long %poke32) +(define %poke-uint %poke32u) +(define %poke-ulong %poke32u) +(define %poke-short %poke16) +(define %poke-ushort %poke16u) +(define %poke-pointer %poke32u) diff --git a/retropikzel/pffi/larceny.scm b/retropikzel/pffi/larceny.scm index c1cb090..d2ee7e4 100644 --- a/retropikzel/pffi/larceny.scm +++ b/retropikzel/pffi/larceny.scm @@ -1,4 +1,6 @@ (require 'std-ffi) +;(require "Standard/foreign-stdlib") +;(require "Lib/Common/system-interface") ;; FIXME (define size-of-type @@ -23,3 +25,115 @@ ((eq? type 'double) 8) ((eq? type 'pointer) 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? + (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))) + + +(define pffi-pointer-set! + (lambda (pointer type offset value) + 0 + #;(cond ((equal? type 'int8) (%poke8 (+ pointer offset) value)) + ((equal? type 'uint8) (%poke8u (+ pointer offset) value)) + ((equal? type 'int16) (%poke16 (+ pointer offset) value)) + ((equal? type 'uint16) (%poke16u (+ pointer offset) value)) + ((equal? type 'int32) (%poke32 (+ pointer offset) value)) + ((equal? type 'uint32) (%poke32u (+ pointer offset) value)) + ;((equal? type 'int64) (%poke64 (+ pointer offset) value)) + ;((equal? type 'uint64) (%poke64u (+ pointer offset) value)) + ((equal? type 'char) (%poke8 (+ pointer offset) value)) + ((equal? type 'short) (%poke-short (+ pointer offset) value)) + ((equal? type 'unsigned-short) (%poke-ushort (+ pointer offset) value)) + ((equal? type 'int) (%poke-int (+ pointer offset) value)) + ((equal? type 'unsigned-int) (%poke-uint (+ pointer offset) value)) + ((equal? type 'long) (%poke-long (+ pointer offset) value)) + ((equal? type 'unsigned-long) (%poke-ulong (+ pointer offset) value)) + ;((equal? type 'float) (%poke-ulong (+ pointer offset) value)) + ;((equal? type 'double) (pointer-set-c-double! pointer offset value)) + ((equal? type 'void) (%poke-pointer (+ pointer offset) value)) + ((equal? type 'pointer) (%poke-pointer (+ pointer offset) value))))) + +(define pffi-pointer-get + (lambda (pointer type offset) + 0 + #;(cond ((equal? type 'int8) (%peek8 (+ pointer offset))) + ((equal? type 'uint8) (%peek8u (+ pointer offset))) + ((equal? type 'int16) (%peek16 (+ pointer offset))) + ((equal? type 'uint16) (%peek16u (+ pointer offset))) + ((equal? type 'int32) (%peek32 (+ pointer offset))) + ((equal? type 'uint32) (%peek32u (+ pointer offset))) + ;((equal? type 'int64) (%peek64 (+ pointer offset))) + ;((equal? type 'uint64) (%peek64u (+ pointer offset))) + ((equal? type 'char) (%peek8 (+ pointer offset))) + ((equal? type 'short) (%peek-short (+ pointer offset))) + ((equal? type 'unsigned-short) (%peek-ushort (+ pointer offset))) + ((equal? type 'int) (%peek-int (+ pointer offset))) + ((equal? type 'unsigned-int) (%peek-uint (+ pointer offset))) + ((equal? type 'long) (%peek-long (+ pointer offset))) + ((equal? type 'unsigned-long) (%peek-ulong (+ pointer offset))) + ;((equal? type 'float) (%peek-ulong (+ pointer offset))) + ;((equal? type 'double) (pointer-set-c-double! pointer offset)) + ((equal? type 'void) (%peek-pointer (+ pointer offset))) + ((equal? type 'pointer) (%peek-pointer (+ pointer offset)))))) + +(define-syntax pffi-define + (syntax-rules () + ((pffi-define scheme-name shared-object c-name return-type argument-types) + (define scheme-name + 0 + + #;(make-c-function shared-object + (symbol->string c-name) + return-type + argument-types))))) + +(define-syntax pffi-define-callback + (syntax-rules () + ((pffi-define scheme-name return-type argument-types procedure) + (define scheme-name + 0 + #;(make-c-callback return-type argument-types procedure))))) diff --git a/retropikzel/pffi/mosh.scm b/retropikzel/pffi/mosh.scm index c0c2b47..15555d6 100644 --- a/retropikzel/pffi/mosh.scm +++ b/retropikzel/pffi/mosh.scm @@ -25,7 +25,7 @@ (else #f)))) (define pffi-shared-object-load - (lambda (header path . options) + (lambda (path . options) (open-shared-library path))) (define pffi-pointer-null @@ -36,7 +36,7 @@ (lambda (pointer) (pointer-null? pointer))) -(define pffi-pointer-allocate +#;(define pffi-pointer-allocate (lambda (size) (malloc size))) @@ -48,7 +48,7 @@ (lambda (object) (pointer? object))) -(define pffi-pointer-free +#;(define pffi-pointer-free (lambda (pointer) (free pointer))) diff --git a/retropikzel/pffi/racket.scm b/retropikzel/pffi/racket.scm index 78e7b1e..c586dad 100644 --- a/retropikzel/pffi/racket.scm +++ b/retropikzel/pffi/racket.scm @@ -53,7 +53,7 @@ (ctype-sizeof native-type) #f)))) -(define pffi-pointer-allocate +#;(define pffi-pointer-allocate (lambda (size) (malloc 'raw size))) @@ -87,7 +87,7 @@ (list #f)))) (ffi-lib path)))) -(define pffi-pointer-free +#;(define pffi-pointer-free (lambda (pointer) (free pointer))) diff --git a/retropikzel/pffi/sagittarius.scm b/retropikzel/pffi/sagittarius.scm index 4ea7fd0..31bf01e 100644 --- a/retropikzel/pffi/sagittarius.scm +++ b/retropikzel/pffi/sagittarius.scm @@ -39,7 +39,7 @@ c-name (map pffi-type->native-type argument-types)))))) -#;(define-syntax pffi-define-callback +(define-syntax pffi-define-callback (syntax-rules () ((_ scheme-name return-type argument-types procedure) (define scheme-name @@ -73,15 +73,15 @@ ((eq? type 'callback) size-of-void*) (else #f)))) -(define pffi-pointer-allocate +#;(define pffi-pointer-allocate (lambda (size) (c-malloc size))) (define pffi-pointer-address (lambda (pointer) - (pointer-address pointer))) + (address pointer 0))) -(define pffi-pointer-null +#;(define pffi-pointer-null (lambda () (empty-pointer))) @@ -105,7 +105,7 @@ (lambda (path options) (open-shared-library path))) -(define pffi-pointer-free +#;(define pffi-pointer-free (lambda (pointer) (when (pointer? pointer) (c-free pointer)))) diff --git a/retropikzel/pffi/shared/pointer.scm b/retropikzel/pffi/shared/pointer.scm new file mode 100644 index 0000000..398d5c9 --- /dev/null +++ b/retropikzel/pffi/shared/pointer.scm @@ -0,0 +1,19 @@ +(cond-expand + ;(kawa #t) ; JVM + (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")))))) + +(pffi-define pffi-pointer-allocate pffi-libc-stdlib 'malloc 'pointer '(int)) +;(pffi-define pffi-pointer-allocate-aligned pffi-libc-stdlib 'aligned_alloc 'pointer '(int int)) +(pffi-define pffi-pointer-free pffi-libc-stdlib 'free 'void '(pointer)) + +#;(define pffi-pointer-null + (lambda () + ; Make aligned_alloc fail and return us a null pointer + (pffi-pointer-allocate-aligned -1 -1))) diff --git a/retropikzel/pffi/shared/struct.scm b/retropikzel/pffi/shared/struct.scm index f702c3f..b3da0d7 100644 --- a/retropikzel/pffi/shared/struct.scm +++ b/retropikzel/pffi/shared/struct.scm @@ -62,7 +62,7 @@ (size (cdr (assoc 'size size-and-offsets))) (offsets (cdr (assoc 'offsets size-and-offsets))) (pointer (if (null? pointer) (pffi-pointer-allocate size) (car pointer))) - (c-typr (if (string? c-type) c-type (symbol->string c-type)))) + (c-type (if (string? c-type) c-type (symbol->string c-type)))) (struct-make c-type size pointer offsets)))) (define (pffi-struct-offset-get struct member-name) diff --git a/retropikzel/pffi/stklos.scm b/retropikzel/pffi/stklos.scm index 90af12c..2c9e8aa 100644 --- a/retropikzel/pffi/stklos.scm +++ b/retropikzel/pffi/stklos.scm @@ -99,7 +99,7 @@ ))) -(define pffi-pointer-allocate +#;(define pffi-pointer-allocate (lambda (size) (allocate-bytes size))) @@ -108,13 +108,14 @@ (lambda (pointer) 0)) +;; FIXME (define pffi-pointer-null (lambda () (let ((p (allocate-bytes 0))) (free-bytes p) p))) -(define pffi-pointer-free +#;(define pffi-pointer-free (lambda (pointer) (free-bytes pointer))) diff --git a/retropikzel/pffi/ypsilon.scm b/retropikzel/pffi/ypsilon.scm index 5b135d6..9cfc55a 100644 --- a/retropikzel/pffi/ypsilon.scm +++ b/retropikzel/pffi/ypsilon.scm @@ -28,7 +28,7 @@ (define c-malloc (c-function void* malloc (size_t))) (define c-free (c-function int free (void*))) -(define pffi-pointer-allocate +#;(define pffi-pointer-allocate (lambda (size) (c-malloc size))) @@ -40,7 +40,7 @@ (lambda (object) (number? object))) -(define pffi-pointer-free +#;(define pffi-pointer-free (lambda (pointer) (c-free pointer))) @@ -118,31 +118,30 @@ (lambda (headers path options) (load-shared-object path))) -(define pffi-type->native-type - (lambda (type) - (cond ((equal? type '(quote int8)) 'int8_t) - ((equal? type '(quote uint8)) 'uint8_t) - ((equal? type '(quote int16)) 'int16_t) - ((equal? type '(quote uint16)) 'uint16_t) - ((equal? type '(quote int32)) 'int32_t) - ((equal? type '(quote uint32)) 'uint32_t) - ((equal? type '(quote int64)) 'int64_t) - ((equal? type '(quote uint64)) 'uint64_t) - ((equal? type '(quote char)) 'char) - ((equal? type '(quote unsigned-char)) 'char) - ((equal? type '(quote short)) 'short) - ((equal? type '(quote unsigned-short)) 'unsigned-short) - ((equal? type '(quote int)) 'int) - ((equal? type '(quote unsigned-int)) 'unsigned-int) - ((equal? type '(quote long)) 'long) - ((equal? type '(quote unsigned-long)) 'unsigned-long) - ((equal? type '(quote float)) 'float) - ((equal? type '(quote double)) 'double) - ((equal? type '(quote pointer)) 'void*) - ((equal? type '(quote string)) 'void*) - ((equal? type '(quote void)) 'void) - ((equal? type '(quote 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 scheme-name shared-object c-name return-type argument-types) diff --git a/tests/compliance.scm b/tests/compliance.scm index 25e49a0..6c990e2 100755 --- a/tests/compliance.scm +++ b/tests/compliance.scm @@ -887,7 +887,7 @@ ;; pffi-struct-dereference ;(print-header "pffi-struct-dereference 1") -;(pffi-define c-color-check-by-value c-testlib 'color_check_by_value 'int '(struct)) +;(pffi-define c-color-check-by-value c-testlib 'color_check_by_value 'int '(uint32)) #;(define struct-color (pffi-struct-make 'color '((int8 . r) (int8 . g) (int8 . b) @@ -896,11 +896,11 @@ ;(debug (pffi-struct-set! struct-color 'g 101)) ;(debug (pffi-struct-set! struct-color 'b 102)) ;(debug (pffi-struct-set! struct-color 'a 103)) -;(assert = (c-color-check-by-value (pffi-struct-dereference struct-color)) 0) +;(assert = (c-color-check-by-value (pffi-pointer-address (pffi-struct-pointer struct-color))) 0) ;(print-header "pffi-struct-dereference 2") -;(pffi-define c-test-check-by-value c-testlib 'test_check_by_value 'int '(struct)) +;(pffi-define c-test-check-by-value c-testlib 'test_check_by_value 'int '(int)) #;(define struct-test3 (pffi-struct-make 'test '((int8 . a) (char . b) @@ -944,7 +944,7 @@ ;(debug (pffi-struct-get struct-test3 'l)) ;(debug (pffi-struct-get struct-test3 'm)) ;(debug (pffi-struct-get struct-test3 'n)) -;(c-test-check-by-value (pffi-struct-dereference struct-test3)) +;(c-test-check-by-value (pffi-pointer-address (pffi-struct-pointer struct-test3))) ;; pffi-define-callback