diff --git a/Makefile b/Makefile index 58a910f..d6cdba0 100644 --- a/Makefile +++ b/Makefile @@ -62,7 +62,8 @@ test-guile: build KAWA=java --add-exports java.base/jdk.internal.foreign.abi=ALL-UNNAMED --add-exports java.base/jdk.internal.foreign.layout=ALL-UNNAMED --add-exports java.base/jdk.internal.foreign=ALL-UNNAMED --enable-native-access=ALL-UNNAMED --enable-preview -jar kawa.jar --r7rs --full-tailcalls -Dkawa.import.path=.:./schubert test-kawa: build - ${SCHEME_RUNNER} kawa "${KAWA} test.scm" + #${SCHEME_RUNNER} kawa "${KAWA} test.scm" + ${KAWA} test.scm SASH=sash -L . -L ./schubert test-sagittarius: build diff --git a/retropikzel/r7rs-pffi/version/kawa.scm b/retropikzel/r7rs-pffi/version/kawa.scm index c29c6c8..8501551 100644 --- a/retropikzel/r7rs-pffi/version/kawa.scm +++ b/retropikzel/r7rs-pffi/version/kawa.scm @@ -43,6 +43,7 @@ ((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 'void) (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 1)) + ((equal? type 'callback) (static-field java.lang.foreign.ValueLayout 'ADDRESS)) (else (error "pffi-type->native-type -- No such pffi type" type))))) (define pffi-type->native-type-old @@ -95,7 +96,20 @@ 'invokeWithArguments (map value->object vals argument-types))))))) - +(define-syntax pffi-define-callback + (syntax-rules () + ((_ scheme-name return-type argument-types procedure) + (define scheme-name + (invoke (invoke (invoke-static java.lang.foreign.Linker 'nativeLinker) + 'upcallStub + procedure + (if (equal? return-type 'void) + (apply (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid) + (map pffi-type->native-type argument-types)) + (apply (class-methods java.lang.foreign.FunctionDescriptor 'of) + (pffi-type->native-type return-type) + (map pffi-type->native-type argument-types))) + arena)))))) (define pffi-size-of (lambda (type) @@ -164,6 +178,3 @@ (lambda (pointer) (invoke pointer 'get (invoke (static-field java.lang.foreign.ValueLayout 'ADDRESS) 'withByteAlignment 1) 0))) -(define pffi-define-callback - (lambda (scheme-name return-type argument-types procedure) - (error "pffi-define-callback not yet implemented for Kawa"))) diff --git a/retropikzel/r7rs-pffi/version/stklos.scm b/retropikzel/r7rs-pffi/version/stklos.scm index 8877f23..b85f358 100644 --- a/retropikzel/r7rs-pffi/version/stklos.scm +++ b/retropikzel/r7rs-pffi/version/stklos.scm @@ -5,7 +5,9 @@ (scheme file) (scheme process-context) (stklos)) - (export pffi-define + (export pffi-shared-object-load + pffi-define + pffi-define-callback pffi-pointer->string pffi-pointer-allocate pffi-pointer-deref @@ -15,7 +17,6 @@ pffi-pointer-null? pffi-pointer-set! pffi-pointer? - pffi-shared-object-load pffi-size-of pffi-string->pointer) (begin @@ -60,6 +61,10 @@ shared-object))))) + (define pffi-define-callback + (lambda () + (error "STklos does not support callbacks"))) + (define pffi-size-of (lambda (type) (error "Not implemented"))) diff --git a/test.scm b/test.scm index 8425587..f9e1a83 100644 --- a/test.scm +++ b/test.scm @@ -338,8 +338,6 @@ (pffi-define atoi libc-stdlib 'atoi 'int (list 'pointer)) (assert = (atoi (pffi-string->pointer "100")) 100) -(exit 0) - ;; pffi-define-callback (print-header 'pffi-define-callback)