From 04d4e43b04608e921d301081b394cbd3657c865a Mon Sep 17 00:00:00 2001 From: retropikzel Date: Sat, 26 Apr 2025 10:49:18 +0300 Subject: [PATCH] Add test for C address of replacement --- Makefile | 1 - retropikzel/pffi/gambit.scm | 34 +++++++++++- retropikzel/pffi/gauche-src/gauchelib.scm | 1 + retropikzel/pffi/kawa.scm | 17 +++--- retropikzel/pffi/mosh.scm | 1 - retropikzel/pffi/racket.scm | 1 - retropikzel/pffi/shared/pointer.scm | 20 +++---- tests/{test-util.scm => addressof.scm} | 35 ++++++++++++ tests/{compliance.scm => old-all.scm} | 0 tests/primitives.scm | 68 ++++++++++++++++++++++- tests/test-util.sld | 7 --- 11 files changed, 153 insertions(+), 32 deletions(-) rename tests/{test-util.scm => addressof.scm} (61%) rename tests/{compliance.scm => old-all.scm} (100%) delete mode 100644 tests/test-util.sld diff --git a/Makefile b/Makefile index db4c4ca..4a0d7dc 100644 --- a/Makefile +++ b/Makefile @@ -67,7 +67,6 @@ 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/*.sld tmp/test/ cp tests/*.scm tmp/test/ cp tests/c-include/libtest.h tmp/test/ cd tmp/test && \ diff --git a/retropikzel/pffi/gambit.scm b/retropikzel/pffi/gambit.scm index 9d765be..11d3e4d 100644 --- a/retropikzel/pffi/gambit.scm +++ b/retropikzel/pffi/gambit.scm @@ -177,8 +177,7 @@ ((equal? type 'double) 'double) ((equal? type 'pointer) '(pointer void)) ((equal? type 'void) 'void) - ((equal? type 'callback) 'c-pointer) - ((equal? type 'struct) 'c-pointer) + ((equal? type 'callback) '(pointer void)) (else (error "pffi-type->native-type -- No such pffi type" type))))) (native-argument-types (if (equal? '(list) argument-types) @@ -207,3 +206,34 @@ (c-lambda ,native-argument-types ,native-return-type ,c-code))))) + +(define-macro + (define-c-callback scheme-name return-type argument-types procedure) + (let* ((type->native-type + (lambda (type) + (cond ((equal? type 'int8) 'byte) + ((equal? type 'uint8) 'unsigned-int8) + ((equal? type 'int16) 'int16_t) + ((equal? type 'uint16) 'uint16_t) + ((equal? type 'int32) 'int32) + ((equal? type 'uint32) 'unsigned-int32) + ((equal? type 'int64) 'int64) + ((equal? type 'uint64) 'unsigned-int64) + ((equal? type 'char) 'char) + ((equal? type 'unsigned-char) 'unsigned-char) + ((equal? type 'short) 'short) + ((equal? type 'unsigned-short) 'unsigned-short) + ((equal? type 'int) 'int) + ((equal? type 'unsigned-int) 'unsigned-int) + ((equal? type 'long) 'long) + ((equal? type 'unsigned-long) 'unsigned-long) + ((equal? type 'float) 'float) + ((equal? type 'double) 'double) + ((equal? type 'pointer) '(pointer void)) + ((equal? type 'void) 'void) + ((equal? type 'callback) '(pointer void)) + (else (error "pffi-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 ,procedure + #;(c-callback ,native-return-type ,native-argument-types ,procedure)))) diff --git a/retropikzel/pffi/gauche-src/gauchelib.scm b/retropikzel/pffi/gauche-src/gauchelib.scm index d801f43..13528a5 100644 --- a/retropikzel/pffi/gauche-src/gauchelib.scm +++ b/retropikzel/pffi/gauche-src/gauchelib.scm @@ -74,6 +74,7 @@ (define-cproc dlerror () pffi_dlerror) (define-cproc dlsym (shared-object c-name) pffi_dlsym) (define-cproc internal-ffi-call (nargs rtype atypes fn rvalue avalues) internal_ffi_call) + (define-cproc scheme-procedure-to-pointer (procedure) scheme_procedure_to_pointer) (define-cproc get-ffi-type-int8 () get_ffi_type_int8) (define-cproc get-ffi-type-uint8 () get_ffi_type_uint8) diff --git a/retropikzel/pffi/kawa.scm b/retropikzel/pffi/kawa.scm index a92459f..b59d5a7 100644 --- a/retropikzel/pffi/kawa.scm +++ b/retropikzel/pffi/kawa.scm @@ -190,12 +190,11 @@ (integer->char r) r)))) -#;(define pffi-struct-dereference - (lambda (struct) - ;; WIP - (pffi-struct-pointer struct) - #;(invoke (pffi-struct-pointer struct) 'reinterpret (static-field java.lang.Integer 'MAX_VALUE)) - #;(invoke (pffi-struct-pointer struct) - 'get - (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 1) - 0))) +(define-syntax call-with-address-of-c-bytevector + (syntax-rules () + ((_ input-pointer thunk) + (let ((address-pointer (make-c-bytevector (c-size-of 'pointer)))) + (pffi-pointer-set! address-pointer 'pointer 0 input-pointer) + (apply thunk (list address-pointer)) + (set! input-pointer (pffi-pointer-get address-pointer 'pointer 0)) + (c-free address-pointer))))) diff --git a/retropikzel/pffi/mosh.scm b/retropikzel/pffi/mosh.scm index fbde1a9..e4af767 100644 --- a/retropikzel/pffi/mosh.scm +++ b/retropikzel/pffi/mosh.scm @@ -102,7 +102,6 @@ ((equal? type 'pointer) 'void*) ((equal? type 'void) 'void) ((equal? type 'callback) 'void*) - ((equal? type 'struct) 'void*) (else (error "pffi-type->native-type -- No such pffi type" type))))) (define-syntax define-c-procedure diff --git a/retropikzel/pffi/racket.scm b/retropikzel/pffi/racket.scm index 48af8ab..c7bdd9e 100644 --- a/retropikzel/pffi/racket.scm +++ b/retropikzel/pffi/racket.scm @@ -21,7 +21,6 @@ ((equal? type 'pointer) _pointer) ((equal? type 'void) _void) ((equal? type 'callback) _pointer) - ((equal? type 'struct) _pointer) (else #f)))) (define c-bytevector? diff --git a/retropikzel/pffi/shared/pointer.scm b/retropikzel/pffi/shared/pointer.scm index a2c0dd5..a938d99 100644 --- a/retropikzel/pffi/shared/pointer.scm +++ b/retropikzel/pffi/shared/pointer.scm @@ -120,13 +120,13 @@ (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) - (let ((address-pointer (make-c-bytevector (c-size-of 'pointer)))) - ;(pffi-pointer-set! address-pointer 'pointer 0 input-pointer) - (c-bytevector-pointer-set! address-pointer 0 input-pointer) - (apply thunk (list address-pointer)) - ;(set! input-pointer (pffi-pointer-get address-pointer 'pointer 0)) - (set! input-pointer (c-bytevector-pointer-ref address-pointer 0)) - (c-free address-pointer))))) +(cond-expand + (kawa #t) ; Defined in kawa.scm + (else (define-syntax call-with-address-of-c-bytevector + (syntax-rules () + ((_ input-pointer thunk) + (let ((address-pointer (make-c-bytevector (c-size-of 'pointer)))) + (c-bytevector-pointer-set! address-pointer 0 input-pointer) + (apply thunk (list address-pointer)) + (set! input-pointer (c-bytevector-pointer-ref address-pointer 0)) + (c-free address-pointer))))))) diff --git a/tests/test-util.scm b/tests/addressof.scm similarity index 61% rename from tests/test-util.scm rename to tests/addressof.scm index 1d17883..e7a19c8 100644 --- a/tests/test-util.scm +++ b/tests/addressof.scm @@ -1,3 +1,11 @@ +(import (scheme base) + (scheme write) + (scheme char) + (scheme file) + (scheme process-context) + (retropikzel pffi)) + +;; util (define header-count 1) (define print-header @@ -62,3 +70,30 @@ (display ": ") (write value) (newline))))) + +;; call-with-address-of-c-bytevector + +(define-c-library c-testlib + '("libtest.h") + "test" + '((additional-paths ("." "./tests")))) + + +(print-header 'call-with-address-of-c-bytevector) + +(define-c-procedure test-passing-pointer-address + c-testlib + 'test_passing_pointer_address + 'int + '(pointer pointer)) + +(define input-pointer (make-c-bytevector (c-size-of 'int))) +(c-bytevector-s32-native-set! input-pointer 0 100) +(debug (c-bytevector-s32-native-ref input-pointer 0)) +(call-with-address-of-c-bytevector + input-pointer + (lambda (address) + (test-passing-pointer-address input-pointer address))) +(debug input-pointer) +(debug (c-bytevector-s32-native-ref input-pointer 0)) +(assert equal? (= (c-bytevector-s32-native-ref input-pointer 0) 42) #t) diff --git a/tests/compliance.scm b/tests/old-all.scm similarity index 100% rename from tests/compliance.scm rename to tests/old-all.scm diff --git a/tests/primitives.scm b/tests/primitives.scm index 3346988..abc7194 100644 --- a/tests/primitives.scm +++ b/tests/primitives.scm @@ -3,9 +3,75 @@ (scheme char) (scheme file) (scheme process-context) - (test-util) (retropikzel pffi)) +;; 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))))) + + ;; c-size-of (print-header 'c-size-of) diff --git a/tests/test-util.sld b/tests/test-util.sld deleted file mode 100644 index 652b1a0..0000000 --- a/tests/test-util.sld +++ /dev/null @@ -1,7 +0,0 @@ -(define-library - (test-util) - (import (scheme base) - (scheme write) - (scheme process-context)) - (export print-header debug assert) - (include "test-util.scm"))