Added pffi-lambda

Makefile

@@ -2,7 +2,7 @@ VERSION=v0.1.0
 SASH=sash -r7 -L .
 GUILE=guile --r7rs -L .
 RACKET=racket -I r7rs --make -S $(shell pwd) --script
-STKLOS=stklos -A .
+STKLOS=stklos -A . -f
 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=".."
 
 build: build-rkt documentation
@@ -51,6 +51,13 @@ test/string-to-pointer-to-string.scm: build
 	#${STKLOS} $@
 	${KAWA} $@
 
+test/pffi-lambda.scm: build
+	${SASH} $@
+	${GUILE} $@
+	#${RACKET} $@
+	#${STKLOS} $@
+	${KAWA} $@
+
 test/sdl2.scm: build
 	${SASH} $@
 	${GUILE} $@

documentation.md

@@ -2,6 +2,12 @@
 
 ## Procedures
 
+# pffi
+
+
+## Procedures
+
+
 ### pffi-call
 
 Arguments:
@@ -32,3 +38,24 @@ Example:
                                 (cons 'int 4))
 
 
+### pffi-shared-object-load
+
+Arguments:
+- path (string) The path to the shared object you want to load, including any "lib" infront and .so/.dll at the end
+
+Returns:
+
+
+
+### pffi-shared-object-auto-load
+
+Arguments:
+- object-name (symbol)
+ - The name of the dynamic library file you want to load without the "lib" in fron of it or .so/.dll at the end
+- addition-paths (list (string)...)
+ - Any additional paths you want to search for the library
+
+Returns:
+- (object) Shared object, the type depends on the implementation
+
+

manifest.scm

@@ -6,6 +6,7 @@
   (list "guile"
         "racket-minimal"
         "openjdk"
+        "curl"
         "sdl2"
         "sdl2-image"
         "sdl2-ttf"

retropikzel/pffi/v0.1.0/main.rkt

@@ -1,4 +1,5 @@
 #lang r7rs
+;> # pffi
 (define-library
   (retropikzel pffi v0.1.0 main)
   (cond-expand
@@ -37,8 +38,10 @@
               (scheme file)
               (scheme process-context)))
     (else (error "Implementation not supported by r7rs-pffi")))
-  (export pffi-call
+  (export pffi-shared-object-auto-load
-          pffi-types
+          pffi-shared-object-load
+          pffi-call
+          pffi-lambda
           pffi-size-of
           pffi-pointer-allocate
           pffi-pointer-null
@@ -48,8 +51,6 @@
           pffi-pointer-free
           pffi-pointer?
           pffi-pointer-null?
-          pffi-shared-object-load
-          pffi-shared-object-auto-load
           pffi-pointer-set!
           pffi-pointer-get
           pffi-pointer-deref)
@@ -82,21 +83,26 @@
                    (java.lang.Char value))
                   (else value))))))
 
+    ;> ## Procedures
+
     (define platform-file-extension
       (cond-expand
         (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so"))
+        (stklos ".so")
         (windows ".dll")
         (else ".so")))
 
     (define platform-version-file-extension
       (cond-expand
         (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so.0"))
+        (stklos ".so")
         (windows ".dll")
         (else ".so.0")))
 
     (define platform-lib-prefix
       (cond-expand
         (racket (if (equal? (system-type 'os) 'windows) "" "lib"))
+        (stklos ".so")
         (windows "")
         (else "lib")))
 
@@ -123,6 +129,23 @@
          double
          pointer))
 
+    (define string-split
+      (lambda (str mark)
+        (let* ((str-l (string->list str))
+               (res (list))
+               (last-index 0)
+               (index 0)
+               (splitter (lambda (c)
+                           (cond ((char=? c mark)
+                                  (begin
+                                    (set! res (append res (list (string-copy str last-index index))))
+                                    (set! last-index (+ index 1))))
+                                 ((equal? (length str-l) (+ index 1))
+                                  (set! res (append res (list (string-copy str last-index (+ index 1)))))))
+                           (set! index (+ index 1)))))
+          (for-each splitter str-l)
+          res)))
+
     (define auto-load-paths
       (append
         (cond-expand
@@ -138,11 +161,14 @@
               (string-split (get-environment-variable "PATH") #\;)))
           (else
             (append
+              ; Guix
               (list (if (get-environment-variable "GUIX_ENVIRONMENT")
                       (string-append (get-environment-variable "GUIX_ENVIRONMENT") "/lib")
-                      ""))
+                      "")
-              (if (get-environment-variable "LD_LOAD_PATH")
+                    "/run/current-system/profile/lib")
-                (list) ;(string-split (get-environment-variable "LD_LOAD_PATH") #\:)
+              ; Debian
+              (if (get-environment-variable "LD_LIBRARY_PATH")
+                (list (string-split (get-environment-variable "LD_LIBRARY_PATH") #\:))
                 (list))
               (list "/lib/x86_64-linux-gnu"
                     "/usr/lib/x86_64-linux-gnu"
@@ -366,6 +392,48 @@
                      (values-objects (map value->object vals (map car arguments))))
                 (invoke method-handle 'invokeWithArguments values-objects)))))))
 
+    (define pffi-lambda
+      (lambda (shared-object name return-type argument-types)
+        (let ((types (map pffi-type->native-type argument-types))
+              (native-return-type (pffi-type->native-type return-type)))
+          (cond-expand
+            (sagittarius
+              (make-c-function shared-object
+                               native-return-type
+                               name
+                               types))
+            (guile
+              (foreign-library-function shared-object
+                                        (symbol->string name)
+                                        #:return-type native-return-type
+                                        #:arg-types types))
+            (racket
+              (get-ffi-obj name
+                           shared-object
+                           (_cprocedure (mlist->list types)
+                                        native-return-type)))
+            (stklos
+              (stklos (make-external-function
+                        (symbol->string name)
+                        types
+                        native-return-type
+                        shared-object)))
+            (kawa
+              (let* ((of-void (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid))
+                     (of (class-methods java.lang.foreign.FunctionDescriptor 'of))
+                     (function-descriptor (if (equal? return-type 'void)
+                                            (apply of-void types)
+                                            (apply of (append (list native-return-type) types))))
+                     (method-handle (invoke (cdr (assoc 'linker shared-object))
+                                            'downcallHandle
+                                            (invoke (invoke (cdr (assoc 'lookup shared-object))
+                                                            'find
+                                                            (symbol->string name))
+                                                    'orElseThrow)
+                                            function-descriptor)))
+                (lambda vals
+                  (invoke method-handle 'invokeWithArguments (map value->object vals argument-types)))))))))
+
     (define pffi-size-of
       (lambda (type)
         (cond-expand
@@ -416,7 +484,8 @@
 
     (define pffi-string->pointer
       (lambda (string-content)
-        (cond-expand (sagittarius (bytevector->pointer (string->utf8 (string-copy string-content))))
+        (cond-expand
+          (sagittarius (bytevector->pointer (string->utf8 (string-copy string-content))))
           (guile (string->pointer string-content))
           (racket (cast string-content _string _pointer))
           (stklos string-content)
@@ -424,7 +493,8 @@
 
     (define pffi-pointer->string
       (lambda (pointer)
-        (cond-expand (sagittarius (pointer->string pointer))
+        (cond-expand
+          (sagittarius (pointer->string pointer))
           (guile (pointer->string pointer))
           (racket (cast pointer _pointer _string))
           (stklos (cpointer->string pointer))
@@ -432,18 +502,27 @@
 
     (define pffi-pointer->bytevector
       (lambda (pointer size)
-        (cond-expand (sagittarius (pointer->bytevector pointer size))
+        (cond-expand
+          (sagittarius (pointer->bytevector pointer size))
           (guile (pointer->bytevector pointer size))
           (racket (cast pointer _pointer _bytes))
-                     (stklos (error "Not yet implemented: pffi-pointer->bytevector")) ; TODO FIX
+          (stklos (bytevector)) ; TODO FIX
           (kawa (invoke (invoke pointer 'reinterpret size)
                         'toArray
                         (static-field java.lang.foreign.ValueLayout
                                       'JAVA_BYTE))))))
 
+    ;> ### pffi-shared-object-load
+    ;>
+    ;> Arguments:
+    ;> - path (string) The path to the shared object you want to load, including any "lib" infront and .so/.dll at the end
+    ;>
+    ;> Returns:
+    ;>
     (define pffi-shared-object-load
       (lambda (path)
-        (cond-expand (sagittarius (open-shared-library path))
+        (cond-expand
+          (sagittarius (open-shared-library path))
           (guile (load-foreign-library path #:lazy? #f))
           (racket (ffi-lib path))
           (stklos path)
@@ -464,6 +543,16 @@
               (list (cons 'linker linker)
                     (cons 'lookup lookup)))))))
 
+    ;> ### pffi-shared-object-auto-load
+    ;>
+    ;> Arguments:
+    ;> - object-name (symbol)
+    ;>  - The name of the dynamic library file you want to load without the "lib" in fron of it or .so/.dll at the end
+    ;> - addition-paths (list (string)...)
+    ;>  - Any additional paths you want to search for the library
+    ;>
+    ;> Returns:
+    ;> - (object) Shared object, the type depends on the implementation
     (define pffi-shared-object-auto-load
       (lambda (object-name additional-paths)
         (let* ((paths (append auto-load-paths additional-paths))
@@ -509,7 +598,8 @@
 
     (define pffi-pointer-free
       (lambda (pointer)
-        (cond-expand (sagittarius (c-free pointer))
+        (cond-expand
+          (sagittarius (c-free pointer))
           (guile #t)
           (racket (free pointer))
           (stklos (free-bytes pointer))
@@ -517,7 +607,8 @@
 
     (define pffi-pointer-null?
       (lambda (pointer)
-        (cond-expand (sagittarius (null-pointer? pointer))
+        (cond-expand
+          (sagittarius (null-pointer? pointer))
           (guile (null-pointer? pointer))
           (racket (not pointer)) ; #f is the null pointer on racket
           (stklos (cpointer-null? pointer))
@@ -572,7 +663,7 @@
                          ;((equal? native-type '*) (pointer-ref-c-void* p offset))
                          )))
           (racket (ptr-set! pointer type offset 'abs value))
-          (stklos (error "Not yet impelemented: pffi-pointer-set!")) ; TODO FIX
+          (stklos #f) ; TODO FIX
           (kawa (invoke pointer 'set (pffi-type->native-type type) offset value)))))
 
     (define pffi-pointer-get
@@ -626,13 +717,14 @@
                     ;((equal? native-type '*) (pointer-ref-c-void* p offset))
                     )))
           (racket (ptr-ref pointer type 'abs offset))
-          (stklos (error "Not yet implemented: pffi-pointer-get")) ; TODO FIX
+          (stklos #f) ; TODO FIX
           (kawa (invoke pointer 'get (pffi-type->native-type type) offset)))))
 
     (define pffi-pointer-deref
       (lambda (pointer)
-        (cond-expand (sagittarius (deref pointer 0))
+        (cond-expand
+          (sagittarius (deref pointer 0))
           (guile (dereference-pointer pointer))
-                     (racket (error "Not yet implemented: pffi-pointer-deref")) ; TODO FIX
+          (racket #f) ; TODO FIX
-                     (stklos (error "Not yet implemented: pffi-pointer-deref")) ; TODO FIX
+          (stklos #f) ; TODO FIX
           (kawa (invoke pointer 'get (static-field java.lang.foreign.ValueLayout 'ADDRESS) 0)))))))

retropikzel/pffi/v0.1.0/main.scm

@@ -40,6 +40,7 @@
   (export pffi-shared-object-auto-load
           pffi-shared-object-load
           pffi-call
+          pffi-lambda
           pffi-size-of
           pffi-pointer-allocate
           pffi-pointer-null
@@ -86,18 +87,21 @@
     (define platform-file-extension
       (cond-expand
         (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so"))
+        (stklos ".so")
         (windows ".dll")
         (else ".so")))
 
     (define platform-version-file-extension
       (cond-expand
         (racket (if (equal? (system-type 'os) 'windows) ".dll" ".so.0"))
+        (stklos ".so")
         (windows ".dll")
         (else ".so.0")))
 
     (define platform-lib-prefix
       (cond-expand
         (racket (if (equal? (system-type 'os) 'windows) "" "lib"))
+        (stklos ".so")
         (windows "")
         (else "lib")))
 
@@ -387,6 +391,48 @@
                      (values-objects (map value->object vals (map car arguments))))
                 (invoke method-handle 'invokeWithArguments values-objects)))))))
 
+    (define pffi-lambda
+      (lambda (shared-object name return-type argument-types)
+        (let ((types (map pffi-type->native-type argument-types))
+              (native-return-type (pffi-type->native-type return-type)))
+          (cond-expand
+            (sagittarius
+              (make-c-function shared-object
+                               native-return-type
+                               name
+                               types))
+            (guile
+              (foreign-library-function shared-object
+                                        (symbol->string name)
+                                        #:return-type native-return-type
+                                        #:arg-types types))
+            (racket
+              (get-ffi-obj name
+                           shared-object
+                           (_cprocedure (mlist->list types)
+                                        native-return-type)))
+            (stklos
+              (stklos (make-external-function
+                        (symbol->string name)
+                        types
+                        native-return-type
+                        shared-object)))
+            (kawa
+              (let* ((of-void (class-methods java.lang.foreign.FunctionDescriptor 'ofVoid))
+                     (of (class-methods java.lang.foreign.FunctionDescriptor 'of))
+                     (function-descriptor (if (equal? return-type 'void)
+                                            (apply of-void types)
+                                            (apply of (append (list native-return-type) types))))
+                     (method-handle (invoke (cdr (assoc 'linker shared-object))
+                                            'downcallHandle
+                                            (invoke (invoke (cdr (assoc 'lookup shared-object))
+                                                            'find
+                                                            (symbol->string name))
+                                                    'orElseThrow)
+                                            function-descriptor)))
+                (lambda vals
+                  (invoke method-handle 'invokeWithArguments (map value->object vals argument-types)))))))))
+
     (define pffi-size-of
       (lambda (type)
         (cond-expand
@@ -437,7 +483,8 @@
 
     (define pffi-string->pointer
       (lambda (string-content)
-        (cond-expand (sagittarius (bytevector->pointer (string->utf8 (string-copy string-content))))
+        (cond-expand
+          (sagittarius (bytevector->pointer (string->utf8 (string-copy string-content))))
           (guile (string->pointer string-content))
           (racket (cast string-content _string _pointer))
           (stklos string-content)
@@ -445,7 +492,8 @@
 
     (define pffi-pointer->string
       (lambda (pointer)
-        (cond-expand (sagittarius (pointer->string pointer))
+        (cond-expand
+          (sagittarius (pointer->string pointer))
           (guile (pointer->string pointer))
           (racket (cast pointer _pointer _string))
           (stklos (cpointer->string pointer))
@@ -453,10 +501,11 @@
 
     (define pffi-pointer->bytevector
       (lambda (pointer size)
-        (cond-expand (sagittarius (pointer->bytevector pointer size))
+        (cond-expand
+          (sagittarius (pointer->bytevector pointer size))
           (guile (pointer->bytevector pointer size))
           (racket (cast pointer _pointer _bytes))
-                     (stklos (error "Not yet implemented: pffi-pointer->bytevector")) ; TODO FIX
+          (stklos (bytevector)) ; TODO FIX
           (kawa (invoke (invoke pointer 'reinterpret size)
                         'toArray
                         (static-field java.lang.foreign.ValueLayout
@@ -471,7 +520,8 @@
     ;>
     (define pffi-shared-object-load
       (lambda (path)
-        (cond-expand (sagittarius (open-shared-library path))
+        (cond-expand
+          (sagittarius (open-shared-library path))
           (guile (load-foreign-library path #:lazy? #f))
           (racket (ffi-lib path))
           (stklos path)
@@ -547,7 +597,8 @@
 
     (define pffi-pointer-free
       (lambda (pointer)
-        (cond-expand (sagittarius (c-free pointer))
+        (cond-expand
+          (sagittarius (c-free pointer))
           (guile #t)
           (racket (free pointer))
           (stklos (free-bytes pointer))
@@ -555,7 +606,8 @@
 
     (define pffi-pointer-null?
       (lambda (pointer)
-        (cond-expand (sagittarius (null-pointer? pointer))
+        (cond-expand
+          (sagittarius (null-pointer? pointer))
           (guile (null-pointer? pointer))
           (racket (not pointer)) ; #f is the null pointer on racket
           (stklos (cpointer-null? pointer))
@@ -610,7 +662,7 @@
                          ;((equal? native-type '*) (pointer-ref-c-void* p offset))
                          )))
           (racket (ptr-set! pointer type offset 'abs value))
-          (stklos (error "Not yet impelemented: pffi-pointer-set!")) ; TODO FIX
+          (stklos #f) ; TODO FIX
           (kawa (invoke pointer 'set (pffi-type->native-type type) offset value)))))
 
     (define pffi-pointer-get
@@ -664,13 +716,14 @@
                     ;((equal? native-type '*) (pointer-ref-c-void* p offset))
                     )))
           (racket (ptr-ref pointer type 'abs offset))
-          (stklos (error "Not yet implemented: pffi-pointer-get")) ; TODO FIX
+          (stklos #f) ; TODO FIX
           (kawa (invoke pointer 'get (pffi-type->native-type type) offset)))))
 
     (define pffi-pointer-deref
       (lambda (pointer)
-        (cond-expand (sagittarius (deref pointer 0))
+        (cond-expand
+          (sagittarius (deref pointer 0))
           (guile (dereference-pointer pointer))
-                     (racket (error "Not yet implemented: pffi-pointer-deref")) ; TODO FIX
+          (racket #f) ; TODO FIX
-                     (stklos (error "Not yet implemented: pffi-pointer-deref")) ; TODO FIX
+          (stklos #f) ; TODO FIX
           (kawa (invoke pointer 'get (static-field java.lang.foreign.ValueLayout 'ADDRESS) 0)))))))

retropikzel/pffi/v0.1.0/schubert-doc.md

@@ -1,4 +1,4 @@
-# pffi test
+# pffi
 
 
 ## Procedures
@@ -34,9 +34,24 @@ Example:
                                 (cons 'int 4))
 
 
+### pffi-shared-object-load
+
+Arguments:
+- path (string) The path to the shared object you want to load, including any "lib" infront and .so/.dll at the end
+
+Returns:
+
+
+
 ### pffi-shared-object-auto-load
 
 Arguments:
 - object-name (symbol)
+ - The name of the dynamic library file you want to load without the "lib" in fron of it or .so/.dll at the end
+- addition-paths (list (string)...)
+ - Any additional paths you want to search for the library
+
+Returns:
+- (object) Shared object, the type depends on the implementation
 
 

test/pffi-lambda.scm

@@ -0,0 +1,11 @@
+(import (scheme base)
+        (scheme write)
+        (retropikzel pffi v0.1.0 main))
+
+(define libcurl (pffi-shared-object-auto-load "curl" (list)))
+
+(define curl-version (pffi-lambda libcurl 'curl_version 'string (list)))
+
+
+(write (pffi-pointer->string (curl-version)))
+(newline)