Merge pull request 'Done' (#27) from callback-chicken into master

Reviewed-on: https://codeberg.org/r7rs-pffi/pffi/pulls/27

retropikzel/pffi/v0-2-2/chicken.scm

@@ -6,9 +6,11 @@
           (scheme process-context)
           (chicken foreign)
           (chicken syntax)
-          (chicken memory))
+          (chicken memory)
+          (chicken random))
   (export pffi-shared-object-load
           pffi-define
+          pffi-define-callback
           pffi-size-of
           pffi-pointer-allocate
           pffi-pointer-null
@@ -45,6 +47,7 @@
               ((equal? type 'pointer) 'c-pointer)
               ((equal? type 'string) 'c-string)
               ((equal? type 'void) 'void)
+              ((equal? type 'callback) 'c-pointer)
               (else (error "pffi-type->native-type -- No such pffi type" type)))) )
 
     (define pffi-pointer?
@@ -77,6 +80,7 @@
                            ((equal? type 'pointer) 'c-pointer)
                            ((equal? type 'string) 'c-string)
                            ((equal? type 'void) 'void)
+                           ((equal? type 'callback) 'c-pointer)
                            (else (error "pffi-type->native-type -- No such pffi type" type)))))
                  (scheme-name (car (cdr expr)))
                  (c-name (symbol->string (car (cdr (car (cdr (cdr (cdr expr))))))))
@@ -88,9 +92,56 @@
                        (map pffi-type->native-type (map car (map cdr types)))))))
             (if (null? argument-types)
               `(define ,scheme-name
-                 (foreign-lambda ,return-type ,c-name))
+                 (foreign-safe-lambda ,return-type ,c-name))
               `(define ,scheme-name
-                 (foreign-lambda ,return-type ,c-name ,@ argument-types)))))))
+                 (foreign-safe-lambda ,return-type ,c-name ,@ argument-types)))))))
+
+    (define-syntax pffi-define-callback
+      (er-macro-transformer
+        (lambda (expr rename compare)
+          (let* ((pffi-type->native-type
+                   (lambda (type)
+                     (cond ((equal? type 'int8) 'byte)
+                           ((equal? type 'uint8) 'unsigned-byte)
+                           ((equal? type 'int16) 'int16_t)
+                           ((equal? type 'uint16) 'uint16_t)
+                           ((equal? type 'int32) 'int32)
+                           ((equal? type 'uint32) 'unsigned-int32)
+                           ((equal? type 'int64) 'integer-64)
+                           ((equal? type 'uint64) 'unsigned-integer64)
+                           ((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) 'c-pointer)
+                           ((equal? type 'string) 'c-string)
+                           ((equal? type 'void) 'void)
+                           ((equal? type 'callback) 'c-pointer)
+                           (else (error "pffi-type->native-type -- No such pffi type" type)))))
+                 (scheme-name (car (cdr expr)))
+                 (return-type (pffi-type->native-type (car (cdr (car (cdr (cdr expr)))))))
+                 (argument-types
+                   (let ((types (cdr (car (cdr (cdr (cdr expr)))))))
+                     (if (null? types)
+                       '()
+                       (map pffi-type->native-type (map car (map cdr types))))))
+                 (argument-names (car (cdr (car (cdr (cdr (cdr (cdr expr))))))))
+                 (arguments (map
+                              (lambda (name type)
+                                `(,name ,type))
+                              argument-types argument-names))
+                 (procedure-body (cdr (cdr (car (cdr (cdr (cdr (cdr expr)))))))))
+              `(begin (define-external ,(cons 'external_123456789 arguments)
+                                ,return-type
+                                (begin ,@ procedure-body))
+                      (define ,scheme-name (location external_123456789)))
+            ))))
 
     (define-syntax pffi-size-of
       (er-macro-transformer
@@ -127,10 +178,7 @@
 
     (define pffi-string->pointer
       (lambda (string-content)
-        (let* ((size (string-length string-content))
+        (location string-content)))
-               (pointer (pffi-pointer-allocate size)))
-          (move-memory! string-content pointer size 0)
-          pointer)))
 
     (pffi-define strlen #f 'strlen 'int (list 'pointer))
 

test/800_libcurl.scm

@@ -39,13 +39,18 @@
 (define curl-code1 (curl-easy-setopt handle CURLOPT-FOLLOWLOCATION url))
 (define curl-code2 (curl-easy-setopt handle CURLOPT-URL url))
 (define curl-code3 (curl-easy-setopt-callback handle CURLOPT-WRITEFUNCTION collect-result))
+(display "Curl code 1: ")
 (display curl-code1)
 (newline)
+(display "Curl code 2: ")
 (display curl-code2)
 (newline)
+(display "Curl code 3: ")
 (display curl-code3)
 (newline)
-(curl-easy-perform handle)
+(display "Perform: ")
-
+(write (curl-easy-perform handle))
+(newline)
+(display "Response length: ")
 (display (string-length result))
 (newline)