From 466dc7d67478a702b8b3adbbc604d9f5be9cd214 Mon Sep 17 00:00:00 2001
From: retropikzel <retropikzel@iki.fi>
Date: Wed, 25 Sep 2024 19:10:05 +0300
Subject: [PATCH] Bug fixes

---
 retropikzel/r7rs-pffi.sld             |  5 +--
 retropikzel/r7rs-pffi/kawa.scm        | 48 +++++++++------------------
 retropikzel/r7rs-pffi/main.scm        |  1 +
 retropikzel/r7rs-pffi/racket.scm      |  2 ++
 retropikzel/r7rs-pffi/sagittarius.scm | 13 ++++----
 test.scm                              |  8 -----
 6 files changed, 28 insertions(+), 49 deletions(-)

diff --git a/retropikzel/r7rs-pffi.sld b/retropikzel/r7rs-pffi.sld
index 936097b..a16f4cc 100644
--- a/retropikzel/r7rs-pffi.sld
+++ b/retropikzel/r7rs-pffi.sld
@@ -78,7 +78,6 @@
           pffi-pointer-deref
           pffi-os-name)
   (begin
-    (include "r7rs-pffi/main.scm")
     (cond-expand
       (chicken (include "r7rs-pffi/chicken.scm"))
       (cyclone (include "r7rs-pffi/cyclone.scm"))
@@ -88,4 +87,6 @@
       (racket (include "r7rs-pffi/racket.scm"))
       (sagittarius (include "r7rs-pffi/sagittarius.scm"))
       (stklos (include "r7rs-pffi/stklos.scm"))
-      (else #t))))
+      (else #t))
+    (include "r7rs-pffi/main.scm")
+    ))
diff --git a/retropikzel/r7rs-pffi/kawa.scm b/retropikzel/r7rs-pffi/kawa.scm
index f5f3528..d91d6f3 100644
--- a/retropikzel/r7rs-pffi/kawa.scm
+++ b/retropikzel/r7rs-pffi/kawa.scm
@@ -83,14 +83,19 @@
              (looper (+ count 1) (append result (list count)))))))
       (looper from (list)))))
 
+
+
 (define-syntax pffi-define-callback
   (syntax-rules ()
     ((_ scheme-name return-type argument-types procedure)
      (define scheme-name
-       (let* ((helper-object
-                (object ()
-                        ((test1234 a b)
-                          1)))
+       (let* ((callback-procedure
+                (lambda (arg1 . args)
+                  (try-catch
+                    (begin
+                      (apply procedure (append (list arg1) args)))
+                    (ex <java.lang.Throwable>
+                        #f))))
               (function-descriptor
                 (let ((function-descriptor
                         (if (equal? return-type 'void)
@@ -99,40 +104,17 @@
                           (apply (class-methods java.lang.foreign.FunctionDescriptor 'of)
                                  (pffi-type->native-type return-type)
                                  (map pffi-type->native-type argument-types)))))
-                  (write (invoke (class-methods (invoke helper-object 'getClass) 'test1234) 'getName))
+                  (write function-descriptor)
+                  (newline)
+                  (write (invoke function-descriptor 'getClass))
                   (newline)
                   (write function-descriptor)
                   (newline)
-                  (write (invoke function-descriptor 'toMethodType))
-                  (newline)
                   function-descriptor))
-              (method-type
-                (let (
-                      (method-type (invoke function-descriptor 'toMethodType))
-                      ;(method-type (field procedure 'applyMethodType))
-                      )
-                  (write method-type)
-                  (newline)
-                  method-type))
+              ;(method-type (invoke function-descriptor 'toMethodType))
+              (method-type (field callback-procedure 'applyMethodType))
               (method-handle
-                (let (
-                      ;(method-handle (invoke procedure 'getApplyMethod))
-                      (method-handle (invoke (class-methods (invoke helper-object 'getClass) 'test1234) 'getApplyMethod))
-                      #;(method-handle (invoke (class-methods (invoke helper-object 'getClass)
-                                                            'test1234) 'getApplyMethod))
-                      #;(method-handle (invoke method-handle-lookup
-                                             'findStatic
-                                             (invoke helper-object 'getClass)
-                                             (invoke (class-methods (invoke helper-object 'getClass) 'test1234) 'getName)
-                                             method-type
-
-                                             ))
-
-                      )
-                  ;(invoke method-handle-lookup 'revealDirect method-handle)
-                  (write method-handle)
-                  (newline)
-                  ;(set! method-handle (invoke method-handle 'asType method-type))
+                (let* ((method-handle (field callback-procedure 'applyToConsumerDefault)))
                   (write method-handle)
                   (newline)
                   method-handle)))
diff --git a/retropikzel/r7rs-pffi/main.scm b/retropikzel/r7rs-pffi/main.scm
index 31ab2bd..056b6fd 100644
--- a/retropikzel/r7rs-pffi/main.scm
+++ b/retropikzel/r7rs-pffi/main.scm
@@ -1,3 +1,4 @@
+
 (define pffi-os-name
   (cond-expand
     (windows "windows")
diff --git a/retropikzel/r7rs-pffi/racket.scm b/retropikzel/r7rs-pffi/racket.scm
index 2d4da0e..4a22788 100644
--- a/retropikzel/r7rs-pffi/racket.scm
+++ b/retropikzel/r7rs-pffi/racket.scm
@@ -91,6 +91,8 @@
 
    (define pffi-pointer->string
      (lambda (pointer)
+       (when (pffi-pointer-null? pointer)
+         (error "Can not make string from null pointer" pointer))
        (string-copy (cast pointer _pointer _string))))
 
    (define pffi-shared-object-load
diff --git a/retropikzel/r7rs-pffi/sagittarius.scm b/retropikzel/r7rs-pffi/sagittarius.scm
index 4739b2d..9fdb604 100644
--- a/retropikzel/r7rs-pffi/sagittarius.scm
+++ b/retropikzel/r7rs-pffi/sagittarius.scm
@@ -25,7 +25,8 @@
 
 (define pffi-pointer?
   (lambda (object)
-    (pointer? object)))
+    (or (pointer? object)
+        (string? object))))
 
 (define-syntax pffi-define
   (syntax-rules ()
@@ -73,17 +74,17 @@
 
 (define pffi-pointer-null
   (lambda ()
-    (integer->pointer 0)))
+    null-pointer))
 
 (define pffi-string->pointer
   (lambda (string-content)
-    (write string-content)
-    (newline)
-    (bytevector->pointer (string->utf8 string-content))))
+    string-content))
 
 (define pffi-pointer->string
   (lambda (pointer)
-    (pointer->string pointer)))
+    (if (string? pointer)
+      pointer
+      (pointer->string pointer))))
 
 (define pffi-shared-object-load
   (lambda (header path)
diff --git a/test.scm b/test.scm
index 3bbf304..55e560d 100644
--- a/test.scm
+++ b/test.scm
@@ -349,14 +349,6 @@
 
 (pffi-define qsort libc-stdlib 'qsort 'void (list 'pointer 'int 'int 'callback))
 
-(define test1234
-  (lambda (pointer-a pointer-b)
-    (let ((a (pffi-pointer-get pointer-a 'int 0))
-          (b (pffi-pointer-get pointer-b 'int 0)))
-      (cond ((> a b) 1)
-            ((= a b) 0)
-            ((< a b) -1)))))
-
 (pffi-define-callback compare
                       'int
                       (list 'pointer 'pointer)