Started working on Kawa callbacks

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

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

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

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)