Retropikzel
/
foreign-c
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Adding tests for pointers. Cleaned up gitignore

This commit is contained in:
retropikzel 2025-07-07 08:04:42 +03:00
parent 466dc9501a
commit 6631c08bd9
6 changed files with 110 additions and 310 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
.gitignore vendored
View File

@ -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

3
Makefile
View File

@ -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}

1
foreign/c/pointer.scm
View File

@ -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

116
foreign/c/primitives/chibi.scm
View File

@ -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

194
foreign/c/primitives/chibi/foreign-c.stub
View File

@ -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)))

94
tests/pointers.scm Normal file
View File

@ -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)