From 6631c08bd945c1bdc8f7f9d13c3e3ec1dbbfc4fa Mon Sep 17 00:00:00 2001 From: retropikzel Date: Mon, 7 Jul 2025 08:04:42 +0300 Subject: [PATCH] Adding tests for pointers. Cleaned up gitignore --- .gitignore | 12 +- Makefile | 3 +- foreign/c/pointer.scm | 1 - foreign/c/primitives/chibi.scm | 116 +------------ foreign/c/primitives/chibi/foreign-c.stub | 194 ++-------------------- tests/pointers.scm | 94 +++++++++++ 6 files changed, 110 insertions(+), 310 deletions(-) create mode 100644 tests/pointers.scm diff --git a/.gitignore b/.gitignore index 136cac5..50a5fc5 100644 --- a/.gitignore +++ b/.gitignore @@ -1,11 +1,3 @@ -*.h -!include/pffi-gauche.h -!include/libtest.h -*.c -!tests/c-src/*.c -!tests/c-include/*.h -!src/libtest.c -!src/gauche/pffi.c *.swp *.swo docuptmp @@ -32,7 +24,6 @@ size-of test/* test !test/*.scm -retropikzel/pffi/*/*.c retropikzel/pffi/*/*.o* retropikzel/pffi/*/*.so retropikzel/pffi/*/compiled @@ -45,8 +36,7 @@ testfile.test testfile.test snow foreign/c/lib -!foreign/c/primitives/gauche/*.c -!foreign/c/primitives/include/*.h README.html *.tgz *.tar.gz +foreign/c/primitives/chibi/foreign-c.c diff --git a/Makefile b/Makefile index a92deda..73e187a 100644 --- a/Makefile +++ b/Makefile @@ -39,7 +39,8 @@ test-compile-r7rs: tmp/test/libtest.o tmp/test/libtest.so tmp/test/libtest.a cp tests/*.scm tmp/test/ cp tests/c-include/libtest.h tmp/test/ cd tmp/test && \ - COMPILE_R7RS_CHICKEN="-L -static -L -ltest -I. -L." \ + COMPILE_R7RS_CHICKEN="-L -ltest -I. -L." \ + COMPILE_R7RS_KAWA="-J--add-exports=java.base/jdk.internal.foreign.abi=ALL-UNNAMED -J--add-exports=java.base/jdk.internal.foreign.layout=ALL-UNNAMED -J--add-exports=java.base/jdk.internal.foreign=ALL-UNNAMED -J--enable-native-access=ALL-UNNAMED -J--enable-preview" \ COMPILE_R7RS=${SCHEME} \ compile-r7rs -I . -o ${TESTNAME} ${TESTNAME}.scm cd tmp/test && ./${TESTNAME} diff --git a/foreign/c/pointer.scm b/foreign/c/pointer.scm index 46f9f97..d33f40e 100644 --- a/foreign/c/pointer.scm +++ b/foreign/c/pointer.scm @@ -84,7 +84,6 @@ (bytevector->c-bytevector (string->utf8 (string-append string-var (string #\null)))))) (cond-expand - (chibi #t) ; FIXME (chicken #t) ; FIXME (kawa #t) ; FIXME (else (define make-c-null diff --git a/foreign/c/primitives/chibi.scm b/foreign/c/primitives/chibi.scm index 76bfb05..d6fed7c 100644 --- a/foreign/c/primitives/chibi.scm +++ b/foreign/c/primitives/chibi.scm @@ -35,57 +35,6 @@ (or (equal? object #f) ; False can be null pointer (pointer? object)))) -#;(define c-free -(lambda (pointer) - (pointer-free pointer))) - -;(define c-bytevector-u8-set! pointer-set-c-uint8_t!) -;(define c-bytevector-u8-ref pointer-ref-c-uint8_t) - -#;(define 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 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-type->native-type (lambda (type) (cond ((equal? type 'int8) 'int8_t) @@ -106,73 +55,14 @@ ((equal? type 'unsigned-long) 'unsigned-long) ((equal? type 'float) 'float) ((equal? type 'double) 'double) - ((equal? type 'pointer) '(maybe-null void*)) - ((equal? type 'pointer-address) '(maybe-null void*)) + ((equal? type 'pointer) '(maybe-null pointer void*)) + ((equal? type 'pointer-address) '(maybe-null pointer void*)) ((equal? type 'void) 'void) - ((equal? type 'callback) '(maybe-null void*)) + ((equal? type 'callback) '(maybe-null pointer void*)) (else (error "pffi-type->native-type -- No such pffi type" type))))) ;; define-c-procedure -#;(define 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 'pointer-address) 1) - ((equal? type 'callback) (get-ffi-type-pointer))))) - -#;(define type->libffi-type - (lambda (type) - (cond ((equal? type 'int8) 1) - ((equal? type 'uint8) 2) - ((equal? type 'int16) 3) - ((equal? type 'uint16) 4) - ((equal? type 'int32) 5) - ((equal? type 'uint32) 6) - ((equal? type 'int64) 7) - ((equal? type 'uint64) 8) - ((equal? type 'char) 9) - ((equal? type 'unsigned-char) 10) - ((equal? type 'short) 11) - ((equal? type 'unsigned-short) 12) - ((equal? type 'int) 13) - ((equal? type 'unsigned-int) 14) - ((equal? type 'long) 15) - ((equal? type 'unsigned-long) 16) - ((equal? type 'float) 17) - ((equal? type 'double) 18) - ((equal? type 'void) 19) - ((equal? type 'pointer) 20) - ((equal? type 'pointer-address) 21) - ((equal? type 'callback) 22) - (else (error "Undefined type" type))))) - -#;(define argument->pointer - (lambda (value type) - (cond ((procedure? value) (scheme-procedure-to-pointer value)) - (else (let ((pointer (pointer-allocate (size-of-type type)))) - (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 diff --git a/foreign/c/primitives/chibi/foreign-c.stub b/foreign/c/primitives/chibi/foreign-c.stub index 4f4a1ea..ae47bbe 100644 --- a/foreign/c/primitives/chibi/foreign-c.stub +++ b/foreign/c/primitives/chibi/foreign-c.stub @@ -58,203 +58,25 @@ (define-c (maybe-null pointer void*) dlopen (string int)) (define-c (maybe-null pointer void*) dlerror ()) -;(c-declare "void* pointer_null() { return NULL; }") -;(define-c (pointer void*) (pointer-null pointer_null) ()) - -;(c-declare "int is_pointer_null(void* pointer) { if(pointer == NULL) { return 1; } else { return 0; }; }") -;(define-c bool (is-pointer-null is_pointer_null) ((maybe-null pointer void*))) - -;(c-declare "void* pointer_allocate(int size) { return malloc(size); }") -;(define-c (maybe-null pointer void*) (pointer-allocate pointer_allocate) (int)) - (c-declare "sexp is_pointer(struct sexp_struct* object) { if(sexp_cpointerp(object)) { return SEXP_TRUE; } else { return SEXP_FALSE; } }") (define-c sexp (pointer? is_pointer) (sexp)) (c-declare "void c_bytevector_u8_set(void* pointer, int offset, uint8_t value) { *(uint8_t*)((char*)pointer + offset) = value; }") -(define-c void (c-bytevector-u8-set! c_bytevector_u8_set) ((pointer void*) int uint8_t)) +(define-c void (c-bytevector-u8-set! c_bytevector_u8_set) ((maybe-null pointer void*) int uint8_t)) (c-declare "int8_t c_bytevector_u8_ref (void* pointer, int offset) { return *(int8_t*)((char*)pointer + offset); }") -(define-c int8_t (c-bytevector-u8-ref c_bytevector_u8_ref) ((pointer void*) int)) +(define-c int8_t (c-bytevector-u8-ref c_bytevector_u8_ref) ((maybe-null pointer void*) int)) (c-declare "void c_bytevector_pointer_set (void* pointer, int offset, void* value) { char* p = (char*)pointer + offset; *(char**)p = value; }") (define-c void (c-bytevector-pointer-set! c_bytevector_pointer_set) ((pointer void*) int (maybe-null pointer void*))) (c-declare "void* c_bytevector_pointer_ref (void* pointer, int offset) { char* p = (char*)pointer + offset; return *(char**)p; }") -(define-c (maybe-null pointer void*) (c-bytevector-pointer-ref c_bytevector_pointer_ref) ((pointer void*) int)) - -#;(c-declare "void* pointer_address(struct sexp_struct* pointer) { - return &sexp_cpointer_value(pointer); - }") -;(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*))) - -;; pointer-set! -;(c-declare "void pointer_set_c_int8_t(void* pointer, int offset, int8_t value) { *(int8_t*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-int8_t! pointer_set_c_int8_t) ((pointer void*) int int8_t)) -;(c-declare "void pointer_set_c_uint8_t(void* pointer, int offset, uint8_t value) { *(uint8_t*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-uint8_t! pointer_set_c_uint8_t) ((pointer void*) int uint8_t)) -; -;(c-declare "void pointer_set_c_int16_t(void* pointer, int offset, int16_t value) { *(int16_t*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-int16_t! pointer_set_c_int16_t) ((pointer void*) int int16_t)) -;(c-declare "void pointer_set_c_uint16_t(void* pointer, int offset, uint16_t value) { *(uint16_t*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-uint16_t! pointer_set_c_uint16_t) ((pointer void*) int uint16_t)) -; -;(c-declare "void pointer_set_c_int32_t(void* pointer, int offset, int32_t value) { *(int32_t*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-int32_t! pointer_set_c_int32_t) ((pointer void*) int int32_t)) -;(c-declare "void pointer_set_c_uint32_t(void* pointer, int offset, uint32_t value) { *(uint32_t*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-uint32_t! pointer_set_c_uint32_t) ((pointer void*) int uint32_t)) -; -;(c-declare "void pointer_set_c_int64_t(void* pointer, int offset, int64_t value) { *(int64_t*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-int64_t! pointer_set_c_int64_t) ((pointer void*) int int64_t)) -;(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, 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)) -; -;(c-declare "void pointer_set_c_short(void* pointer, int offset, short value) { *(short*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-short! pointer_set_c_short) ((pointer void*) int short)) -;(c-declare "void pointer_set_c_unsigned_short(void* pointer, int offset, unsigned short value) { *(unsigned short*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-unsigned-short! pointer_set_c_unsigned_short) ((pointer void*) int unsigned-short)) -; -;(c-declare "void pointer_set_c_int(void* pointer, int offset, int value) { *(int*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-int! pointer_set_c_int) ((pointer void*) int int)) -;(c-declare "void pointer_set_c_unsigned_int(void* pointer, int offset, unsigned int value) { *(unsigned int*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-unsigned-int! pointer_set_c_unsigned_int) ((pointer void*) int unsigned-int)) -; -;(c-declare "void pointer_set_c_long(void* pointer, int offset, long value) { *(long*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-long! pointer_set_c_long) ((pointer void*) int long)) -;(c-declare "void pointer_set_c_unsigned_long(void* pointer, int offset, unsigned long value) { *(unsigned long*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-unsigned-long! pointer_set_c_unsigned_long) ((pointer void*) int unsigned-long)) -; -;(c-declare "void pointer_set_c_float(void* pointer, int offset, float value) { *(float*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-float! pointer_set_c_float) ((pointer void*) int float)) -; -;(c-declare "void pointer_set_c_double(void* pointer, int offset, double value) { *(double*)((char*)pointer + offset) = value; }") -;(define-c void (pointer-set-c-double! pointer_set_c_double) ((pointer void*) int double)) -; -;(c-declare "void pointer_set_c_pointer(void* pointer, int offset, void* value) { char* p = (char*)pointer + offset; *(char**)p = value; }") -;(define-c void (pointer-set-c-pointer! pointer_set_c_pointer) ((pointer void*) int (maybe-null pointer void*))) -; -;;; pointer-get -;(c-declare "int8_t pointer_ref_c_int8_t(void* pointer, int offset) { return *(int8_t*)((char*)pointer + offset); }") -;(define-c int8_t (pointer-ref-c-int8_t pointer_ref_c_int8_t) ((pointer void*) int)) -;(c-declare "uint8_t pointer_ref_c_uint8_t(void* pointer, int offset) { return *(uint8_t*)((char*)pointer + offset); }") -;(define-c uint8_t (pointer-ref-c-uint8_t pointer_ref_c_uint8_t) ((pointer void*) int)) -; -;(c-declare "int16_t pointer_ref_c_int16_t(void* pointer, int offset) { return *(int16_t*)((char*)pointer + offset); }") -;(define-c int16_t (pointer-ref-c-int16_t pointer_ref_c_int16_t) ((pointer void*) int)) -;(c-declare "uint16_t pointer_ref_c_uint16_t(void* pointer, int offset) { return *(uint16_t*)((char*)pointer + offset); }") -;(define-c uint16_t (pointer-ref-c-uint16_t pointer_ref_c_uint16_t) ((pointer void*) int)) -; -;(c-declare "int32_t pointer_ref_c_int32_t(void* pointer, int offset) { return *(int32_t*)((char*)pointer + offset); }") -;(define-c int32_t (pointer-ref-c-int32_t pointer_ref_c_int32_t) ((pointer void*) int)) -;(c-declare "uint32_t pointer_ref_c_uint32_t(void* pointer, int offset) { return *(uint32_t*)((char*)pointer + offset); }") -;(define-c uint32_t (pointer-ref-c-uint32_t pointer_ref_c_uint32_t) ((pointer void*) int)) -; -;(c-declare "int64_t pointer_ref_c_int64_t(void* pointer, int offset) { return *(int64_t*)((char*)pointer + offset); }") -;(define-c int64_t (pointer-ref-c-int64_t pointer_ref_c_int64_t) ((pointer void*) int)) -;(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 "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)) -; -;(c-declare "short pointer_ref_c_short(void* pointer, int offset) { return *(short*)((char*)pointer + offset); }") -;(define-c short (pointer-ref-c-short pointer_ref_c_short) ((pointer void*) int)) -;(c-declare "unsigned short pointer_ref_c_unsigned_short(void* pointer, int offset) { return *(unsigned short*)((char*)pointer + offset); }") -;(define-c unsigned-short (pointer-ref-c-unsigned-short pointer_ref_c_unsigned_short) ((pointer void*) int)) -; -;(c-declare "int pointer_ref_c_int(void* pointer, int offset) { return *(int*)((char*)pointer + offset); }") -;(define-c int (pointer-ref-c-int pointer_ref_c_int) ((pointer void*) int)) -;(c-declare "unsigned int pointer_ref_c_unsigned_int(void* pointer, int offset) { return *(unsigned int*)((char*)pointer + offset); }") -;(define-c unsigned-int (pointer-ref-c-unsigned-int pointer_ref_c_unsigned_int) ((pointer void*) int)) -; -;(c-declare "long pointer_ref_c_long(void* pointer, int offset) { return *(long*)((char*)pointer + offset); }") -;(define-c long (pointer-ref-c-long pointer_ref_c_long) ((pointer void*) long)) -;(c-declare "unsigned long pointer_ref_c_unsigned_long(void* pointer, int offset) { return *(unsigned long*)((char*)pointer + offset); }") -;(define-c unsigned-long (pointer-ref-c-unsigned-long pointer_ref_c_unsigned_long) ((pointer void*) int)) -; -;(c-declare "float pointer_ref_c_float(void* pointer, int offset) { return *(float*)((char*)pointer + offset); }") -;(define-c float (pointer-ref-c-float pointer_ref_c_float) ((pointer void*) int)) -; -;(c-declare "double pointer_ref_c_double(void* pointer, int offset) { return *(double*)((char*)pointer + offset); }") -;(define-c double (pointer-ref-c-double pointer_ref_c_double) ((pointer void*) int)) -; -;(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)) - -;; define-c-procedure +(define-c (maybe-null pointer void*) (c-bytevector-pointer-ref c_bytevector_pointer_ref) ((maybe-null pointer void*) int)) (c-declare "ffi_cif cif;") -(define-c (pointer void*) dlsym ((maybe-null pointer void*) string)) - -;(c-declare "void* get_ffi_type_int8() { return &ffi_type_sint8; }") -;(define-c (pointer void*) (get-ffi-type-int8 get_ffi_type_int8) ()) -;(c-declare "void* get_ffi_type_uint8() { return &ffi_type_uint8; }") -;(define-c (pointer void*) (get-ffi-type-uint8 get_ffi_type_uint8) ()) -; -;(c-declare "void* get_ffi_type_int16() { return &ffi_type_sint16; }") -;(define-c (pointer void*) (get-ffi-type-int16 get_ffi_type_int16) ()) -;(c-declare "void* get_ffi_type_uint16() { return &ffi_type_uint16; }") -;(define-c (pointer void*) (get-ffi-type-uint16 get_ffi_type_uint16) ()) -; -;(c-declare "void* get_ffi_type_int32() { return &ffi_type_sint32; }") -;(define-c (pointer void*) (get-ffi-type-int32 get_ffi_type_int32) ()) -;(c-declare "void* get_ffi_type_uint32() { return &ffi_type_uint32; }") -;(define-c (pointer void*) (get-ffi-type-uint32 get_ffi_type_uint32) ()) -; -;(c-declare "void* get_ffi_type_int64() { return &ffi_type_sint64; }") -;(define-c (pointer void*) (get-ffi-type-int64 get_ffi_type_int64) ()) -;(c-declare "void* get_ffi_type_uint64() { return &ffi_type_uint64; }") -;(define-c (pointer void*) (get-ffi-type-uint64 get_ffi_type_uint64) ()) -; -;(c-declare "void* get_ffi_type_char() { return &ffi_type_schar; }") -;(define-c (pointer void*) (get-ffi-type-char get_ffi_type_char) ()) -;(c-declare "void* get_ffi_type_uchar() { return &ffi_type_uchar; }") -;(define-c (pointer void*) (get-ffi-type-uchar get_ffi_type_uchar) ()) -; -;(c-declare "void* get_ffi_type_short() { return &ffi_type_sshort; }") -;(define-c (pointer void*) (get-ffi-type-short get_ffi_type_short) ()) -;(c-declare "void* get_ffi_type_ushort() { return &ffi_type_ushort; }") -;(define-c (pointer void*) (get-ffi-type-ushort get_ffi_type_ushort) ()) -; -;(c-declare "void* get_ffi_type_int() { return &ffi_type_sint; }") -;(define-c (pointer void*) (get-ffi-type-int get_ffi_type_int) ()) -;(c-declare "void* get_ffi_type_uint() { return &ffi_type_uint; }") -;(define-c (pointer void*) (get-ffi-type-uint get_ffi_type_uint) ()) -; -;(c-declare "void* get_ffi_type_long() { return &ffi_type_slong; }") -;(define-c (pointer void*) (get-ffi-type-long get_ffi_type_long) ()) -; -;(c-declare "void* get_ffi_type_ulong() { return &ffi_type_ulong; }") -;(define-c (pointer void*) (get-ffi-type-ulong get_ffi_type_ulong) ()) -; -;(c-declare "void* get_ffi_type_float() { return &ffi_type_float; }") -;(define-c (pointer void*) (get-ffi-type-float get_ffi_type_float) ()) -; -;(c-declare "void* get_ffi_type_double() { return &ffi_type_double; }") -;(define-c (pointer void*) (get-ffi-type-double get_ffi_type_double) ()) -; -;(c-declare "void* get_ffi_type_void() { return &ffi_type_void; }") -;(define-c (pointer void*) (get-ffi-type-void get_ffi_type_void) ()) -; -;(c-declare "void* get_ffi_type_pointer() { return &ffi_type_pointer; }") -;(define-c (pointer void*) (get-ffi-type-pointer get_ffi_type_pointer) ()) +(define-c (maybe-null pointer void*) dlsym ((maybe-null pointer void*) string)) (define-c-const int (FFI-OK "FFI_OK")) -#;(c-declare - "int internal_ffi_prep_cif(unsigned int nargs, void* rtype, void* atypes[]) { - printf(\"A1: %u, A2: %u, nargs: %u\\n\", &ffi_type_pointer, atypes[0], nargs); - return ffi_prep_cif(&cif, FFI_DEFAULT_ABI, nargs, (ffi_type*)rtype, (ffi_type**)atypes); - }") -;(define-c int (internal-ffi-prep-cif internal_ffi_prep_cif) (unsigned-int (pointer void*) (array void*))) (c-declare "void* internal_ffi_call( unsigned int nargs, @@ -383,7 +205,11 @@ break; case 20: c_atypes[i] = &ffi_type_pointer; - vals20[i] = sexp_cpointer_value(avalues[i]); + if(avalues[i] != NULL) { + vals20[i] = sexp_cpointer_value(avalues[i]); + } else { + vals20[i] = NULL; + } c_avalues[i] = &vals20[i]; break; default: @@ -432,7 +258,7 @@ (unsigned-int unsigned-int (array unsigned-int) - (pointer void*) + (maybe-null pointer void*) unsigned-int (array sexp))) diff --git a/tests/pointers.scm b/tests/pointers.scm new file mode 100644 index 0000000..91d8a80 --- /dev/null +++ b/tests/pointers.scm @@ -0,0 +1,94 @@ +(import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme process-context) + (foreign c)) + +;; util +(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))))) + +(define-c-library libc '("stdlib.h" "stdio.h" "time.h") libc-name '((additional-versions ("6")))) +(define-c-procedure c-fopen libc 'fopen 'pointer '(pointer pointer)) +(define-c-procedure c-fclose libc 'fclose 'int '(pointer)) +(define-c-procedure c-time libc 'time 'int '(pointer)) +(define-c-procedure c-srand libc 'srand 'void '(int)) +(define-c-procedure c-rand libc 'rand 'int '()) + +(print-header "pointers 1") + +(define p (make-c-bytevector 100)) +(debug p) +(assert equal? (c-bytevector? p) #t) + +(define n (make-c-null)) +(debug n) +(assert equal? (c-bytevector? n) #t) + +(c-srand (c-time (make-c-null))) + +(define random-integer (c-rand)) +(assert equal? (number? random-integer) #t)