diff --git a/Makefile b/Makefile index 0168c3a..db4c4ca 100644 --- a/Makefile +++ b/Makefile @@ -67,15 +67,16 @@ ypsilon: 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/*.sld tmp/test/ + cp tests/*.scm tmp/test/ cp tests/c-include/libtest.h 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 + compile-r7rs -I . -o ${TESTNAME} ${TESTNAME}.scm cd tmp/test && \ LD_LIBRARY_PATH=. \ - ./compliance + ./${TESTNAME} test-compile-r7rs-docker: docker build --build-arg COMPILE_R7RS=${COMPILE_R7RS} --tag=r7rs-pffi-test-${COMPILE_R7RS} -f dockerfiles/test . diff --git a/retropikzel/pffi.sld b/retropikzel/pffi.sld index a68f504..a513050 100644 --- a/retropikzel/pffi.sld +++ b/retropikzel/pffi.sld @@ -85,7 +85,8 @@ (primitives std-ffi) (primitives foreign-procedure) (primitives foreign-file) - (primitives foreign-stdlib))) + (primitives foreign-stdlib) + (primitives system-interface))) (mosh (import (scheme base) (scheme write) @@ -176,9 +177,11 @@ pointer-ref-c-pointer void?)) (export make-external-function - calculate-struct-size-and-offsets - struct-make - pffi:string-split)) + ; calculate-struct-size-and-offsets + ;struct-make + pffi:string-split + c-bytevector-pointer-set! + c-bytevector-pointer-ref)) (tr7 (import (scheme base) (scheme write) @@ -200,10 +203,13 @@ c-size-of define-c-library define-c-procedure - ;pffi-define-callback; define-c-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-u8-ref + + ;; c-bytevector + ;pffi-pointer-set!;c-bytevector-u8-set! and so on + ;pffi-pointer-get;c-bytevector-u8-ref and so on native-endianness ;; TODO Docs for all of these c-bytevector->address @@ -211,7 +217,6 @@ c-bytevector-s8-set! c-bytevector-s8-ref c-bytevector-u8-set! - c-bytevector-u8-ref c-bytevector-s16-set! c-bytevector-s16-native-set! c-bytevector-s16-ref @@ -237,13 +242,9 @@ c-bytevector-u64-ref c-bytevector-u64-native-ref c-bytevector-sint-set! - c-bytevector-sint-native-set! c-bytevector-sint-ref - c-bytevector-sint-native-ref c-bytevector-uint-set! - c-bytevector-uint-native-set! c-bytevector-uint-ref - c-bytevector-uint-native-ref c-bytevector-ieee-single-set! c-bytevector-ieee-single-native-set! c-bytevector-ieee-single-ref @@ -271,22 +272,22 @@ ;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 + ;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 + ;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 (?) @@ -313,15 +314,17 @@ (skint (include "pffi/skint.scm")) (stklos (include "pffi/stklos.scm")) (tr7 (include "pffi/tr7.scm")) - (ypsilon (export c-function) + (ypsilon (export c-function c-callback) (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/array.scm") + ;(include-relative "pffi/shared/struct.scm") + ) (else (include "pffi/shared/main.scm") - (include "pffi/shared/struct.scm") + ;(include "pffi/shared/struct.scm") (include "pffi/shared/c-bytevectors.scm") (include "pffi/shared/pointer.scm") - (include "pffi/shared/array.scm")))) + ;(include "pffi/shared/array.scm") + ))) diff --git a/retropikzel/pffi/chibi.scm b/retropikzel/pffi/chibi.scm index d149e02..f1f468d 100644 --- a/retropikzel/pffi/chibi.scm +++ b/retropikzel/pffi/chibi.scm @@ -49,7 +49,7 @@ (pointer-free pointer))) (define c-bytevector-u8-ref pointer-ref-c-uint8_t) -(define c-bytevector-u8-set! pointer-set-c-uint8_t!) +;(define c-bytevector-u8-set! pointer-set-c-uint8_t!) (define pffi-pointer-set! (lambda (pointer type offset value) diff --git a/retropikzel/pffi/chicken.scm b/retropikzel/pffi/chicken.scm index 90b999a..0206941 100644 --- a/retropikzel/pffi/chicken.scm +++ b/retropikzel/pffi/chicken.scm @@ -1,13 +1,13 @@ -(define pffi-type->native-type ; Chicken has this procedure in three places +(define type->native-type ; Chicken has this procedure in three places (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 'int16) 'short) + ((equal? type 'uint16) 'unsigned-short) + ((equal? type 'int32) 'integer32) + ((equal? type 'uint32) 'unsigned-integer32) + ((equal? type 'int64) 'integer64) ((equal? type 'uint64) 'unsigned-integer64) ((equal? type 'char) 'char) ((equal? type 'unsigned-char) 'unsigned-char) @@ -23,7 +23,7 @@ ((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)))) ) + (else (error "type->native-type -- No such pffi type" type))))) (define c-bytevector? (lambda (object) @@ -32,15 +32,15 @@ (define-syntax define-c-procedure (er-macro-transformer (lambda (expr rename compare) - (let* ((pffi-type->native-type ; Chicken has this procedure in three places + (let* ((type->native-type ; Chicken has this procedure in three places (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 'int16) 'short) + ((equal? type 'uint16) 'unsigned-short) + ((equal? type 'int32) 'integer32) + ((equal? type 'uint32) 'unsigned-integer32) + ((equal? type 'int64) 'integer64) ((equal? type 'uint64) 'unsigned-integer64) ((equal? type 'char) 'char) ((equal? type 'unsigned-char) 'unsigned-char) @@ -56,13 +56,13 @@ ((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))))) + (else (error "type->native-type -- No such pffi type" type))))) (scheme-name (list-ref expr 1)) (c-name (symbol->string (cadr (list-ref expr 3)))) - (return-type (pffi-type->native-type (cadr (list-ref expr 4)))) + (return-type (type->native-type (cadr (list-ref expr 4)))) (argument-types (if (null? (cdr (list-ref expr 5))) (list) - (map pffi-type->native-type + (map type->native-type (cadr (list-ref expr 5)))))) (if (null? argument-types) `(define ,scheme-name @@ -70,18 +70,18 @@ `(define ,scheme-name (foreign-safe-lambda ,return-type ,c-name ,@ argument-types))))))) -(define-syntax pffi-define-callback +(define-syntax define-c-callback (er-macro-transformer (lambda (expr rename compare) - (let* ((pffi-type->native-type ; Chicken has this procedure in three places + (let* ((type->native-type ; Chicken has this procedure in three places (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 'int16) 'short) + ((equal? type 'uint16) 'unsigned-short) + ((equal? type 'int32) 'integer32) + ((equal? type 'uint32) 'unsigned-integer32) + ((equal? type 'int64) 'integer64) ((equal? type 'uint64) 'unsigned-integer64) ((equal? type 'char) 'char) ((equal? type 'unsigned-char) 'unsigned-char) @@ -97,10 +97,10 @@ ((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))))) + (else (error "type->native-type -- No such pffi type" type))))) (scheme-name (list-ref expr 1)) - (return-type (pffi-type->native-type (cadr (list-ref expr 2)))) - (argument-types (map pffi-type->native-type (cadr (list-ref expr 3)))) + (return-type (type->native-type (cadr (list-ref expr 2)))) + (argument-types (map type->native-type (cadr (list-ref expr 3)))) (argument-names (cadr (list-ref expr 4))) (arguments (map (lambda (name type) @@ -145,9 +145,9 @@ ((_ scheme-name headers object-name options) (begin (define scheme-name #t) - (pffi-shared-object-load headers))))) + (shared-object-load headers))))) -(define-syntax pffi-shared-object-load +(define-syntax shared-object-load (er-macro-transformer (lambda (expr rename compare) (let* ((headers (cadr (car (cdr expr))))) @@ -167,13 +167,13 @@ (define c-bytevector-u8-ref (lambda (c-bytevector k) - (pointer-s8-ref (pointer+ c-bytevector k)))) + (pointer-u8-ref (pointer+ c-bytevector k)))) -(define c-bytevector-u8-set! +#;(define c-bytevector-u8-set! (lambda (c-bytevector k byte) - (pointer-s8-set! (pointer+ c-bytevector k) byte))) + (pointer-u8-set! (pointer+ c-bytevector k) byte))) -(define pffi-pointer-set! +#;(define pffi-pointer-set! (lambda (pointer type offset value) (cond ((equal? type 'int8) (pointer-s8-set! (pointer+ pointer offset) value)) @@ -195,7 +195,7 @@ ((equal? type 'double) (pointer-f64-set! (pointer+ pointer offset) value)) ((equal? type 'pointer) (pointer-u64-set! (pointer+ pointer offset) (pointer->address value)))))) -(define pffi-pointer-get +#;(define pffi-pointer-get (lambda (pointer type offset) (cond ((equal? type 'int8) (pointer-s8-ref (pointer+ pointer offset))) diff --git a/retropikzel/pffi/cyclone.scm b/retropikzel/pffi/cyclone.scm index 60b8d7c..4bb1910 100644 --- a/retropikzel/pffi/cyclone.scm +++ b/retropikzel/pffi/cyclone.scm @@ -345,7 +345,7 @@ "make_c_opaque(opq, (void*)opaque_ptr(pointer) + obj_obj2int(offset)); return_closcall1(data, k, &opq);") -(define c-bytevector-u8-set! pffi-pointer-uint8-set!) +#;(define c-bytevector-u8-set! pffi-pointer-uint8-set!) (define c-bytevector-u8-ref pffi-pointer-uint8-get) (define pffi-pointer-get diff --git a/retropikzel/pffi/gambit.scm b/retropikzel/pffi/gambit.scm index 34d2096..9d765be 100644 --- a/retropikzel/pffi/gambit.scm +++ b/retropikzel/pffi/gambit.scm @@ -66,7 +66,7 @@ (lambda (x) #f) (lambda () (pointer? object))))))) -(define c-bytevector-u8-set! (c-lambda ((pointer void) int unsigned-int8) void "*(uint8_t*)((char*)___arg1 + ___arg2) = ___arg3;")) +#;(define c-bytevector-u8-set! (c-lambda ((pointer void) int unsigned-int8) void "*(uint8_t*)((char*)___arg1 + ___arg2) = ___arg3;")) (define c-bytevector-u8-ref (c-lambda ((pointer void) int) unsigned-int8 "___return(*(uint8_t*)((char*)___arg1 + ___arg2));")) (define pointer-set-c-int8_t! (c-lambda ((pointer void) int int8) void "*(int8_t*)((char*)___arg1 + ___arg2) = ___arg3;")) diff --git a/retropikzel/pffi/gauche.scm b/retropikzel/pffi/gauche.scm index ec70147..05a9d7d 100644 --- a/retropikzel/pffi/gauche.scm +++ b/retropikzel/pffi/gauche.scm @@ -1,15 +1,18 @@ (define-module retropikzel.pffi.gauche (export size-of-type pffi-shared-object-load + c-bytevector-u8-set! + c-bytevector-u8-ref ;pffi-pointer-null ;pffi-pointer-null? make-c-bytevector - pffi-pointer-address + ;pffi-pointer-address c-bytevector? c-free pffi-pointer-set! pffi-pointer-get - define-c-procedure)) + define-c-procedure + define-c-callback)) (select-module retropikzel.pffi.gauche) (dynamic-load "retropikzel/pffi/gauche-pffi") @@ -55,6 +58,9 @@ (lambda (pointer) (pointer-free pointer))) +;(define c-bytevector-u8-set! pointer-set-uint8!) +(define c-bytevector-u8-ref pointer-get-uint8) + (define pffi-pointer-set! (lambda (pointer type offset value) (cond ((equal? type 'int8) (pointer-set-int8! pointer offset value)) @@ -99,7 +105,7 @@ ((equal? type 'void) (pointer-get-pointer pointer offset)) ((equal? type 'pointer) (pointer-get-pointer pointer offset))))) -(define pffi-type->libffi-type +(define type->libffi-type (lambda (type) (cond ((equal? type 'int8) (get-ffi-type-int8)) ((equal? type 'uint8) (get-ffi-type-uint8)) @@ -144,8 +150,8 @@ 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) + (type->libffi-type return-type) + (map type->libffi-type argument-types) c-function return-value (map argument->pointer @@ -167,7 +173,7 @@ (lambda (return-type argument-types procedure) (scheme-procedure-to-pointer procedure))) -(define-syntax pffi-define-callback +(define-syntax define-c-callback (syntax-rules () ((_ scheme-name return-type argument-types procedure) (define scheme-name diff --git a/retropikzel/pffi/guile.scm b/retropikzel/pffi/guile.scm index 1638d29..cd56cc5 100644 --- a/retropikzel/pffi/guile.scm +++ b/retropikzel/pffi/guile.scm @@ -20,7 +20,6 @@ ((equal? type 'double) double) ((equal? type 'pointer) '*) ((equal? type 'void) void) - ((equal? type 'string) '*) ((equal? type 'callback) '*) ((equal? type 'struct) '*) (else #f)))) @@ -38,7 +37,7 @@ #:return-type (pffi-type->native-type return-type) #:arg-types (map pffi-type->native-type argument-types)))))) -(define-syntax pffi-define-callback +(define-syntax define-c-callback (syntax-rules () ((_ scheme-name return-type argument-types procedure) (define scheme-name @@ -57,7 +56,7 @@ (lambda (path options) (load-foreign-library path))) -(define c-bytevector-u8-set! +#;(define c-bytevector-u8-set! (lambda (c-bytevector k byte) (let ((p (pointer->bytevector c-bytevector (+ k 100)))) (bytevector-u8-set! p k byte)))) diff --git a/retropikzel/pffi/kawa.scm b/retropikzel/pffi/kawa.scm index 6578e68..a92459f 100644 --- a/retropikzel/pffi/kawa.scm +++ b/retropikzel/pffi/kawa.scm @@ -48,7 +48,6 @@ ((equal? type 'float) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_FLOAT) 'withByteAlignment 4)) ((equal? type 'double) (invoke (static-field java.lang.foreign.ValueLayout 'JAVA_DOUBLE) 'withByteAlignment 8)) ((equal? type 'pointer) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8)) - ((equal? type 'string) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8)) ((equal? type 'void) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 1)) ((equal? type 'callback) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8)) ((equal? type 'struct) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 8)) @@ -89,7 +88,7 @@ (looper (+ count 1) (append result (list count))))))) (looper from (list))))) -(define-syntax pffi-define-callback +(define-syntax define-c-callback (syntax-rules () ((_ scheme-name return-type argument-types procedure) (define scheme-name diff --git a/retropikzel/pffi/larceny.scm b/retropikzel/pffi/larceny.scm index 656c792..c0b3769 100644 --- a/retropikzel/pffi/larceny.scm +++ b/retropikzel/pffi/larceny.scm @@ -1,4 +1,5 @@ (require 'std-ffi) +(require 'ffi-load) ;; FIXME (define size-of-type @@ -21,67 +22,23 @@ ((eq? type 'unsigned-long) 4) ((eq? type 'float) 4) ((eq? type 'double) 8) - ((eq? type 'pointer) 4) + ((eq? type 'pointer) sizeof:pointer) ((eq? type 'void) 0) - ((eq? type 'callback) 4) + ((eq? type 'callback) sizeof:pointer) (else (error "Can not get size of unknown type" type))))) (define c-bytevector? (lambda (object) ;(void*? object) - (number? object) - )) + (number? object))) (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 c-bytevector-u8-ref + (lambda (c-bytevector k) + (peek-bytes c-bytevector k (c-size-of 'uint8)))) (define-syntax define-c-procedure (syntax-rules () diff --git a/retropikzel/pffi/mosh.scm b/retropikzel/pffi/mosh.scm index 85cb796..fbde1a9 100644 --- a/retropikzel/pffi/mosh.scm +++ b/retropikzel/pffi/mosh.scm @@ -32,7 +32,7 @@ (lambda (object) (pointer? object))) -(define c-bytevector-u8-set! pointer-set-c-uint8!) +;(define c-bytevector-u8-set! pointer-set-c-uint8!) (define c-bytevector-u8-ref pointer-ref-c-uint8) (define pffi-pointer-set! @@ -100,7 +100,6 @@ ((equal? type 'float) 'float) ((equal? type 'double) 'double) ((equal? type 'pointer) 'void*) - ((equal? type 'string) 'char*) ((equal? type 'void) 'void) ((equal? type 'callback) 'void*) ((equal? type 'struct) 'void*) @@ -115,7 +114,7 @@ c-name (map pffi-type->native-type argument-types)))))) -(define-syntax pffi-define-callback +(define-syntax define-c-callback (syntax-rules () ((_ scheme-name return-type argument-types procedure) (define scheme-name diff --git a/retropikzel/pffi/racket.scm b/retropikzel/pffi/racket.scm index 295c9f4..48af8ab 100644 --- a/retropikzel/pffi/racket.scm +++ b/retropikzel/pffi/racket.scm @@ -37,7 +37,7 @@ (_cprocedure (mlist->list (map pffi-type->native-type argument-types)) (pffi-type->native-type return-type))))))) -(define-syntax pffi-define-callback +(define-syntax define-c-callback (syntax-rules () ((pffi-define-callback scheme-name return-type argument-types procedure) (define scheme-name (function-ptr procedure @@ -61,7 +61,7 @@ (list #f)))) (ffi-lib path)))) -(define c-bytevector-u8-set! +#;(define c-bytevector-u8-set! (lambda (c-bytevector k byte) (ptr-set! c-bytevector _uint8 'abs k byte))) diff --git a/retropikzel/pffi/sagittarius.scm b/retropikzel/pffi/sagittarius.scm index e381c93..f9c4fc4 100644 --- a/retropikzel/pffi/sagittarius.scm +++ b/retropikzel/pffi/sagittarius.scm @@ -20,7 +20,6 @@ ((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)))) @@ -49,10 +48,8 @@ ((equal? type 'float) 'float) ((equal? type 'double) 'double) ((equal? type 'pointer) 'void*) - ((equal? type 'string) 'void*) ((equal? type 'void) 'void) ((equal? type 'callback) 'callback) - ((and (pair? type) (equal? 'struct (car type))) 'void*) (else #f)))) (define-syntax define-c-procedure @@ -64,7 +61,7 @@ c-name (map pffi-type->native-type argument-types)))))) -(define-syntax pffi-define-callback +(define-syntax define-c-callback (syntax-rules () ((_ scheme-name return-type argument-types procedure) (define scheme-name @@ -76,9 +73,8 @@ (lambda (object) (pointer? object))) +;(define c-bytevector-u8-set! pointer-set-c-uint8_t!) (define c-bytevector-u8-ref pointer-ref-c-uint8_t) -(define c-bytevector-u8-set! pointer-set-c-uint8_t!) - (define pffi-pointer-set! (lambda (pointer type offset value) diff --git a/retropikzel/pffi/shared/main.scm b/retropikzel/pffi/shared/main.scm index fe8425d..ad5587b 100644 --- a/retropikzel/pffi/shared/main.scm +++ b/retropikzel/pffi/shared/main.scm @@ -24,7 +24,8 @@ (define c-size-of (lambda (object) - (cond ((pffi-struct? object) (pffi-struct-size object)) + (size-of-type 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))))) diff --git a/retropikzel/pffi/shared/pointer.scm b/retropikzel/pffi/shared/pointer.scm index b54e6ec..a2c0dd5 100644 --- a/retropikzel/pffi/shared/pointer.scm +++ b/retropikzel/pffi/shared/pointer.scm @@ -11,6 +11,7 @@ (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-memset-address libc 'memset 'pointer '(uint64 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)) @@ -111,6 +112,14 @@ (native-endianness) (c-size-of 'pointer))))) +(cond-expand + (kawa #t) ; Defined in kawa.scm + (else + (define c-bytevector-u8-set! + (lambda (c-bytevector k byte) + (let ((address (c-memset-pointer->address c-bytevector 0 0))) + (c-memset-address (+ address k) byte 1)))))) + (define-syntax call-with-address-of-c-bytevector (syntax-rules () ((_ input-pointer thunk) diff --git a/retropikzel/pffi/stklos.scm b/retropikzel/pffi/stklos.scm index f6ad69c..0acf130 100644 --- a/retropikzel/pffi/stklos.scm +++ b/retropikzel/pffi/stklos.scm @@ -1,4 +1,4 @@ -(define pffi-type->native-type +(define type->native-type (lambda (type) (cond ((equal? type 'int8) :char) ((equal? type 'uint8) :char) @@ -20,8 +20,8 @@ ((equal? type 'double) :double) ((equal? type 'pointer) :pointer) ((equal? type 'void) :void) - ((equal? type 'struct) :void) - (else (error "pffi-type->native-type -- No such pffi type" type))))) + ((equal? type 'callback) :pointer) + (else (error "type->native-type -- No such pffi type" type))))) (define c-bytevector? (lambda (object) @@ -31,39 +31,38 @@ (syntax-rules () ((_ scheme-name shared-object c-name return-type argument-types) (begin - (define pffi-type->native-type - (lambda (type) - (cond ((equal? type 'int8) :int) - ((equal? type 'uint8) :uint) - ((equal? type 'int16) :int) - ((equal? type 'uint16) :uint) - ((equal? type 'int32) :int) - ((equal? type 'uint32) :uint) - ((equal? type 'int64) :int) - ((equal? type 'uint64) :uint) - ((equal? type 'char) :char) - ((equal? type 'unsigned-char) :uchar) - ((equal? type 'short) :short) - ((equal? type 'unsigned-short) :ushort) - ((equal? type 'int) :int) - ((equal? type 'unsigned-int) :uint) - ((equal? type 'long) :long) - ((equal? type 'unsigned-long) :ulong) - ((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 scheme-name - (make-external-function - (symbol->string c-name) - (map pffi-type->native-type argument-types) - (pffi-type->native-type return-type) - shared-object)))))) + (define type->native-type + (lambda (type) + (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) :long) + ((equal? type 'uint64) :ulong) + ((equal? type 'char) :char) + ((equal? type 'unsigned-char) :uchar) + ((equal? type 'short) :short) + ((equal? type 'unsigned-short) :ushort) + ((equal? type 'int) :int) + ((equal? type 'unsigned-int) :uint) + ((equal? type 'long) :long) + ((equal? type 'unsigned-long) :ulong) + ((equal? type 'float) :float) + ((equal? type 'double) :double) + ((equal? type 'pointer) :pointer) + ((equal? type 'void) :void) + ((equal? type 'callback) :pointer) + (else (error "type->native-type -- No such pffi type" type))))) + (define scheme-name + (make-external-function + (symbol->string c-name) + (map type->native-type argument-types) + (type->native-type return-type) + shared-object)))))) -(define pffi-define-callback +(define define-c-callback (lambda () (error "Not implemented"))) @@ -90,7 +89,7 @@ ((equal? type 'double) 8) ((equal? type 'pointer) 8)))) -(define c-bytevector-u8-set! pointer-set-c-uint8_t!) +;(define c-bytevector-u8-set! pointer-set-c-uint8_t!) (define c-bytevector-u8-ref pointer-ref-c-uint8_t) (define pffi-pointer-set! diff --git a/retropikzel/pffi/ypsilon.scm b/retropikzel/pffi/ypsilon.scm index e83f098..fc159c4 100644 --- a/retropikzel/pffi/ypsilon.scm +++ b/retropikzel/pffi/ypsilon.scm @@ -19,7 +19,6 @@ ((eq? type 'float) (c-sizeof float)) ((eq? type 'double) (c-sizeof double)) ((eq? type 'pointer) (c-sizeof void*)) - ((eq? type 'string) (c-sizeof void*)) ((eq? type 'struct) (c-sizeof void*)) ((eq? type 'callback) (c-sizeof void*)) ((eq? type 'void) 0) @@ -29,7 +28,7 @@ (lambda (object) (number? object))) -(define c-bytevector-u8-set! +#;(define c-bytevector-u8-set! (lambda (c-bytevector k byte) (bytevector-c-int8-set! (make-bytevector-mapping (+ c-bytevector k) (c-size-of 'uint8)) @@ -93,7 +92,7 @@ (load-shared-object path))) #;(define-macro - (pffi-type->native-type type) + (type->native-type type) `(cond ((equal? ,type 'int8) 'int8_t) ((equal? ,type 'uint8) 'uint8_t) ;((equal? ,type 'int16) 'int16_t) @@ -113,15 +112,14 @@ ;((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)))) + (else (error "type->native-type -- No such pffi type" ,type)))) (define-macro (define-c-procedure scheme-name shared-object c-name return-type argument-types) (begin - (let ((pffi-type->native-type + (let ((type->native-type (lambda (type) (cond ((equal? type 'int8) 'int8_t) ((equal? type 'uint8) 'uint8_t) @@ -142,43 +140,41 @@ ((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)))))) + (else (error "type->native-type -- No such pffi type" type)))))) `(define ,scheme-name - (c-function ,(pffi-type->native-type (cadr return-type)) + (c-function ,(type->native-type (cadr return-type)) ,(cadr c-name) - ,(map pffi-type->native-type (cadr argument-types))))))) + ,(map 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-c-callback scheme-name return-type argument-types procedure) + (let* ((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 'void) 'void) + ((equal? type 'callback) 'void*) + (else (error "type->native-type -- No such pffi type" type))))) + (native-return-type (type->native-type (cadr return-type))) + (native-argument-types (map type->native-type (cadr argument-types)))) `(define ,scheme-name - (c-callback ,(pffi-type->native-type return-type) - ,(map pffi-type->native-type (cdr argument-types)) - ,procedure)))) + (c-callback ,native-return-type ,native-argument-types ,procedure)))) diff --git a/tests/compliance.scm b/tests/compliance.scm index ba00d65..38d9829 100755 --- a/tests/compliance.scm +++ b/tests/compliance.scm @@ -560,56 +560,56 @@ ; pffi-define-struct -(print-header "pffi-define-struct") +;(print-header "pffi-define-struct") +; +;(pffi-define-struct test-struct1 'teststruct1 '((int . r) (int . g) (int . b))) +;(define struct1 (test-struct1)) +;(debug struct1) +;(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 (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 (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 (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 (c-size-of struct5)) +;(assert = (c-size-of struct5) 24) -(pffi-define-struct test-struct1 'teststruct1 '((int . r) (int . g) (int . b))) -(define struct1 (test-struct1)) -(debug struct1) -(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 (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 (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 (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 (c-size-of struct5)) -(assert = (c-size-of struct5) 24) - -(pffi-define-struct test-struct6 'test6 '((int8 . a) - (char . b) - (double . c) - (char . d) - (pointer . e) - (float . f) - (pointer . g) - (int8 . h) - (pointer . i) - (int . j) - (int . k) - (int . l) - (double . m) - (float . n))) -(define struct6 (test-struct6)) -(debug struct6) -(debug (c-size-of struct6)) -(assert = (c-size-of struct6) 96) +;(pffi-define-struct test-struct6 'test6 '((int8 . a) +; (char . b) +; (double . c) +; (char . d) +; (pointer . e) +; (float . f) +; (pointer . g) +; (int8 . h) +; (pointer . i) +; (int . j) +; (int . k) +; (int . l) +; (double . m) +; (float . n))) +;(define struct6 (test-struct6)) +;(debug struct6) +;(debug (c-size-of struct6)) +;(assert = (c-size-of struct6) 96) ;; bytevector->c-bytevector c-bytevector->bytevector @@ -628,112 +628,112 @@ ;; pffi-struct-get -(print-header 'pffi-struct-get) - -(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) - (double . c) - (char . d) - (pointer . e) - (float . f) - (pointer . g) - (int8 . h) - (pointer . i) - (int . j) - (int . k) - (int . l) - (double . m) - (float . n))) -(define struct-test (struct-test-get1)) -(c-check-offset 1 (pffi-struct-offset-get struct-test 'a)) -(c-check-offset 2 (pffi-struct-offset-get struct-test 'b)) -(c-check-offset 3 (pffi-struct-offset-get struct-test 'c)) -(c-check-offset 4 (pffi-struct-offset-get struct-test 'd)) -(c-check-offset 5 (pffi-struct-offset-get struct-test 'e)) -(c-check-offset 6 (pffi-struct-offset-get struct-test 'f)) -(c-check-offset 7 (pffi-struct-offset-get struct-test 'g)) -(c-check-offset 8 (pffi-struct-offset-get struct-test 'h)) -(c-check-offset 9 (pffi-struct-offset-get struct-test 'i)) -(c-check-offset 10 (pffi-struct-offset-get struct-test 'j)) -(c-check-offset 11 (pffi-struct-offset-get struct-test 'k)) -(c-check-offset 12 (pffi-struct-offset-get struct-test 'l)) -(c-check-offset 13 (pffi-struct-offset-get struct-test 'm)) -(c-check-offset 14 (pffi-struct-offset-get struct-test 'n)) -(debug struct-test) -(c-init-struct (pffi-struct-pointer struct-test)) -(debug struct-test) - -(debug (pffi-struct-get struct-test 'a)) -(assert = (pffi-struct-get struct-test 'a) 1) -(debug (pffi-struct-get struct-test 'b)) -(assert char=? (pffi-struct-get struct-test 'b) #\b) -(debug (pffi-struct-get struct-test 'c)) -(assert = (pffi-struct-get struct-test 'c) 3.0) -(debug (pffi-struct-get struct-test 'd)) -(assert char=? (pffi-struct-get struct-test 'd) #\d) -(debug (pffi-struct-get struct-test 'e)) -(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 (c-utf8->string (pffi-struct-get struct-test 'g))) -(assert equal? (string=? (c-utf8->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 (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)) -(assert = (pffi-struct-get struct-test 'k) 11) -(debug (pffi-struct-get struct-test 'l)) -(assert = (pffi-struct-get struct-test 'l) 12) -(debug (pffi-struct-get struct-test 'm)) -(assert = (pffi-struct-get struct-test 'm) 13.0) -(debug (pffi-struct-get struct-test 'n)) -(assert = (pffi-struct-get struct-test 'n) 14.0) - -;; pffi-struct-set! 1 - -(print-header "pffi-struct-set! 1") - -(define-c-procedure c-test-check c-testlib 'test_check 'int '(pointer)) -(pffi-define-struct struct-test-set1 'test_set1 - '((int8 . a) - (char . b) - (double . c) - (char . d) - (pointer . e) - (float . f) - (pointer . g) - (int8 . h) - (pointer . i) - (int . j) - (int . k) - (int . l) - (double . m) - (float . n))) -(define struct-test1 (struct-test-set1)) -(pffi-struct-set! struct-test1 'a 1) -(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 (make-c-null)) -(pffi-struct-set! struct-test1 'f 6.0) -(pffi-struct-set! struct-test1 'g (string->c-utf8 "foo")) -(pffi-struct-set! struct-test1 'h 8) -(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) -(pffi-struct-set! struct-test1 'm 13.0) -(pffi-struct-set! struct-test1 'n 14.0) -(c-test-check (pffi-struct-pointer struct-test1)) +;(print-header 'pffi-struct-get) +; +;(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) +; (double . c) +; (char . d) +; (pointer . e) +; (float . f) +; (pointer . g) +; (int8 . h) +; (pointer . i) +; (int . j) +; (int . k) +; (int . l) +; (double . m) +; (float . n))) +;(define struct-test (struct-test-get1)) +;(c-check-offset 1 (pffi-struct-offset-get struct-test 'a)) +;(c-check-offset 2 (pffi-struct-offset-get struct-test 'b)) +;(c-check-offset 3 (pffi-struct-offset-get struct-test 'c)) +;(c-check-offset 4 (pffi-struct-offset-get struct-test 'd)) +;(c-check-offset 5 (pffi-struct-offset-get struct-test 'e)) +;(c-check-offset 6 (pffi-struct-offset-get struct-test 'f)) +;(c-check-offset 7 (pffi-struct-offset-get struct-test 'g)) +;(c-check-offset 8 (pffi-struct-offset-get struct-test 'h)) +;(c-check-offset 9 (pffi-struct-offset-get struct-test 'i)) +;(c-check-offset 10 (pffi-struct-offset-get struct-test 'j)) +;(c-check-offset 11 (pffi-struct-offset-get struct-test 'k)) +;(c-check-offset 12 (pffi-struct-offset-get struct-test 'l)) +;(c-check-offset 13 (pffi-struct-offset-get struct-test 'm)) +;(c-check-offset 14 (pffi-struct-offset-get struct-test 'n)) +;(debug struct-test) +;(c-init-struct (pffi-struct-pointer struct-test)) +;(debug struct-test) +; +;(debug (pffi-struct-get struct-test 'a)) +;(assert = (pffi-struct-get struct-test 'a) 1) +;(debug (pffi-struct-get struct-test 'b)) +;(assert char=? (pffi-struct-get struct-test 'b) #\b) +;(debug (pffi-struct-get struct-test 'c)) +;(assert = (pffi-struct-get struct-test 'c) 3.0) +;(debug (pffi-struct-get struct-test 'd)) +;(assert char=? (pffi-struct-get struct-test 'd) #\d) +;(debug (pffi-struct-get struct-test 'e)) +;(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 (c-utf8->string (pffi-struct-get struct-test 'g))) +;(assert equal? (string=? (c-utf8->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 (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)) +;(assert = (pffi-struct-get struct-test 'k) 11) +;(debug (pffi-struct-get struct-test 'l)) +;(assert = (pffi-struct-get struct-test 'l) 12) +;(debug (pffi-struct-get struct-test 'm)) +;(assert = (pffi-struct-get struct-test 'm) 13.0) +;(debug (pffi-struct-get struct-test 'n)) +;(assert = (pffi-struct-get struct-test 'n) 14.0) +; +;;; pffi-struct-set! 1 +; +;(print-header "pffi-struct-set! 1") +; +;(define-c-procedure c-test-check c-testlib 'test_check 'int '(pointer)) +;(pffi-define-struct struct-test-set1 'test_set1 +; '((int8 . a) +; (char . b) +; (double . c) +; (char . d) +; (pointer . e) +; (float . f) +; (pointer . g) +; (int8 . h) +; (pointer . i) +; (int . j) +; (int . k) +; (int . l) +; (double . m) +; (float . n))) +;(define struct-test1 (struct-test-set1)) +;(pffi-struct-set! struct-test1 'a 1) +;(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 (make-c-null)) +;(pffi-struct-set! struct-test1 'f 6.0) +;(pffi-struct-set! struct-test1 'g (string->c-utf8 "foo")) +;(pffi-struct-set! struct-test1 'h 8) +;(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) +;(pffi-struct-set! struct-test1 'm 13.0) +;(pffi-struct-set! struct-test1 'n 14.0) +;(c-test-check (pffi-struct-pointer struct-test1)) ;; pffi-struct constructor with pointer @@ -794,31 +794,34 @@ ; Array utilities -(print-header "Array utilities") - -(define test-list1 (list 1 2 3)) -(debug test-list1) -(debug (pffi-list->array 'int test-list1)) -(assert equal? (pffi-array->list (pffi-list->array 'int test-list1)) test-list1) - -(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)) -(assert equal? (pffi-array->list (pffi-pointer->array test-array1 'int 3)) check-list1) - -(define test-array2 (pffi-array-allocate 'int 5)) -(debug (pffi-array->list test-array2)) -(assert equal? (pffi-array->list test-array2) (list 0 0 0 0 0)) -(pffi-array-set! test-array2 2 1) -(debug (pffi-array->list test-array2)) -(assert equal? (pffi-array->list test-array2) (list 0 0 1 0 0)) -(assert = (pffi-array-get test-array2 1) 0) -(assert = (pffi-array-get test-array2 2) 1) -(assert = (pffi-array-get test-array2 3) 0) +;(print-header "Array utilities") +; +;(define test-list1 (list 1 2 3)) +;(debug test-list1) +;(debug (pffi-list->array 'int test-list1)) +;(assert equal? (pffi-array->list (pffi-list->array 'int test-list1)) test-list1) +; +;(define test-array1 (make-c-bytevector (* (c-size-of 'int) 3))) +;;(pffi-pointer-set! test-array1 'int (* (c-size-of 'int) 0) 4) +;(c-bytevector-s32-set! test-array1 0 4 (native-endianness)) +;;(pffi-pointer-set! test-array1 'int (* (c-size-of 'int) 1) 5) +;(c-bytevector-s32-set! test-array1 1 5 (native-endianness)) +;;(pffi-pointer-set! test-array1 'int (* (c-size-of 'int) 2) 6) +;(c-bytevector-s32-set! test-array1 2 6 (native-endianness)) +;(debug test-array1) +;(define check-list1 (list 4 5 6)) +;(debug (pffi-array->list (pffi-pointer->array test-array1 'int 3))) +;(assert equal? (pffi-array->list (pffi-pointer->array test-array1 'int 3)) check-list1) +; +;(define test-array2 (pffi-array-allocate 'int 5)) +;(debug (pffi-array->list test-array2)) +;(assert equal? (pffi-array->list test-array2) (list 0 0 0 0 0)) +;(pffi-array-set! test-array2 2 1) +;(debug (pffi-array->list test-array2)) +;(assert equal? (pffi-array->list test-array2) (list 0 0 1 0 0)) +;(assert = (pffi-array-get test-array2 1) 0) +;(assert = (pffi-array-get test-array2 2) 1) +;(assert = (pffi-array-get test-array2 3) 0) ;; pffi-struct-dereference 1 diff --git a/tests/primitives.scm b/tests/primitives.scm new file mode 100644 index 0000000..3346988 --- /dev/null +++ b/tests/primitives.scm @@ -0,0 +1,285 @@ +(import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme process-context) + (test-util) + (retropikzel pffi)) + +;; c-size-of + +(print-header 'c-size-of) + +(define size-int8 (c-size-of 'int8)) +(debug size-int8) +(assert equal? (number? size-int8) #t) +(assert = size-int8 1) + +(define size-uint8 (c-size-of 'uint8)) +(debug size-uint8) +(assert equal? (number? size-uint8) #t) +(assert = size-uint8 1) + +(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? (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? (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? (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? (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? (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? (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? (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? (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? (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? (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? (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? (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? (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? (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? (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? (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? (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 (c-size-of 'pointer)) + (debug size-pointer) + (assert equal? (number? size-pointer) #t) + (assert = size-pointer 4)) + (else + (define size-pointer (c-size-of 'pointer)) + (debug size-pointer) + (assert equal? (number? size-pointer) #t) + (assert = size-pointer 8))) + +;; define-c-library + +(print-header 'pffi-define-library) + +(cond-expand + (windows (define-c-library libc-stdlib + '("stdlib.h") + "ucrtbase" + '((additional-versions ("0" "6"))))) + (else (define-c-library libc-stdlib + '("stdlib.h") + "c" + '((additional-versions ("0" "6")))))) + +(debug libc-stdlib) + +(cond-expand + (windows (define-c-library libc-stdio + '("stdio.h") + "ucrtbase" + '((additional-versions ("0" "6"))))) + (else (define-c-library libc-stdio + '("stdio.h") + "c" + '((additional-versions ("0" "6")))))) + +(debug libc-stdio) + +(define-c-library c-testlib + '("libtest.h") + "test" + '((additional-paths ("." "./tests")))) + +(debug c-testlib) + +;; define-c-procedure + +(print-header 'define-c-procedure) + +(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-utf8 "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-utf8 "100")) 100) + +(define-c-procedure c-fopen libc-stdio 'fopen 'pointer '(pointer pointer)) +(define output-file (c-fopen (string->c-utf8 "testfile.test") + (string->c-utf8 "w"))) +(debug output-file) +(define-c-procedure c-fprintf libc-stdio 'fprintf 'int '(pointer pointer)) +(define characters-written + (c-fprintf output-file (string->c-utf8 "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) + +;; c-bytevector-u8-ref + +(print-header "c-bytevector-u8-ref") + +(define u8-pointer (make-c-bytevector (c-size-of 'uint8))) +(c-bytevector-u8-set! u8-pointer 0 42) +(debug u8-pointer) +(debug (c-bytevector-u8-ref u8-pointer 0)) +(assert equal? (= (c-bytevector-u8-ref u8-pointer 0) 42) #t) + +;; define-c-callback + +(print-header 'define-c-callback) + +(define array (make-c-bytevector (* (c-size-of 'int) 3))) +(c-bytevector-s32-native-set! array (* (c-size-of 'int) 0) 3) +(c-bytevector-s32-native-set! array (* (c-size-of 'int) 1) 2) +(c-bytevector-s32-native-set! array (* (c-size-of 'int) 2) 1) + +(define-c-procedure qsort libc-stdlib 'qsort 'void '(pointer int int callback)) + +(define-c-callback compare + 'int + '(pointer pointer) + (lambda (pointer-a pointer-b) + (let ((a (c-bytevector-s32-native-ref pointer-a 0)) + (b (c-bytevector-s32-native-ref pointer-b 0))) + (cond ((> a b) 1) + ((= a b) 0) + ((< a b) -1))))) +(write compare) +(newline) + +(define unsorted (list (c-bytevector-s32-native-ref array (* (c-size-of 'int) 0)) + (c-bytevector-s32-native-ref array (* (c-size-of 'int) 1)) + (c-bytevector-s32-native-ref array (* (c-size-of 'int) 2)))) +(debug unsorted) +(assert equal? unsorted (list 3 2 1)) + +(qsort array 3 (c-size-of 'int) compare) + +(define sorted (list (c-bytevector-s32-native-ref array (* (c-size-of 'int) 0)) + (c-bytevector-s32-native-ref array (* (c-size-of 'int) 1)) + (c-bytevector-s32-native-ref array (* (c-size-of 'int) 2)))) +(debug sorted) +(assert equal? sorted (list 1 2 3)) + +(exit 0) diff --git a/tests/test-util.scm b/tests/test-util.scm new file mode 100644 index 0000000..1d17883 --- /dev/null +++ b/tests/test-util.scm @@ -0,0 +1,64 @@ +(define header-count 1) + +(define print-header + (lambda (title) + (set-tag title) + (display "=========================================") + (newline) + (display header-count) + (display " ") + (display title) + (newline) + (display "=========================================") + (newline) + (set! header-count (+ header-count 1)))) + +(define count 0) +(define assert-tag 'none) + +(define set-tag + (lambda (tag) + (set! assert-tag tag) + (set! count 0))) + +(cond-expand + (gambit + (define assert + (lambda (check value-a value-b) + (let ((result (apply check (list value-a value-b)))) + (set! count (+ count 1)) + (if (not result) (display "FAIL ") (display "PASS ")) + (display "[") + (display assert-tag) + (display " - ") + (display count) + (display "]") + (display ": ") + (write (list 'check 'value-a 'value-b)) + (newline) + (when (not result) (exit 1)))))) + (else + (define-syntax assert + (syntax-rules () + ((_ check value-a value-b) + (let ((result (apply check (list value-a value-b)))) + (set! count (+ count 1)) + (if (not result) (display "FAIL ") (display "PASS ")) + (display "[") + (display assert-tag) + (display " - ") + (display count) + (display "]") + (display ": ") + (write (list 'check 'value-a 'value-b)) + (newline) + (when (not result) (exit 1)))))))) + +(define-syntax debug + (syntax-rules () + ((_ value) + (begin + (display 'value) + (display ": ") + (write value) + (newline))))) diff --git a/tests/test-util.sld b/tests/test-util.sld new file mode 100644 index 0000000..652b1a0 --- /dev/null +++ b/tests/test-util.sld @@ -0,0 +1,7 @@ +(define-library + (test-util) + (import (scheme base) + (scheme write) + (scheme process-context)) + (export print-header debug assert) + (include "test-util.scm"))