Added most of the support for mosh, some bugs remain and couple of unimplemented procedures. Got Gerbil to load files.

Makefile

@@ -38,6 +38,15 @@ test-gambit: clean
 test-gauche:
 	gosh -r7 -A . test.scm
 
+GERBIL_LIB=gxc -O
+GERBIL=GERBIL_LOADPATH=. gxi --lang r7rs
+test-gerbil-podman-amd64:
+	podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/gerbil bash -c "cd /workdir && ${GERBIL_LIB} retropikzel/r7rs-pffi.sld"
+	podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/gerbil bash -c "cd /workdir && ${GERBIL} test.scm"
+
+test-gerbil:
+	gxi --lang r7rs test.scm
+
 GUILE=guile --r7rs --fresh-auto-compile -L .
 test-guile-podman-amd64:
 	podman run --arch=amd64 -it -v ${PWD}:/workdir schemers/guile bash -c "cd /workdir && ${GUILE} test.scm"

gerbil.pkg

@@ -0,0 +1 @@
+(prelude: :scheme/r7rs)

retropikzel/r7rs-pffi.sld

@@ -111,17 +111,17 @@
           pffi-shared-object-load
           pffi-pointer-null
           pffi-pointer-null?
-          ;pffi-define
+          pffi-pointer-allocate
-          ;pffi-define-callback
+          pffi-pointer?
-          ;pffi-pointer-allocate
+          pffi-pointer-free
+          pffi-pointer-set!
+          pffi-pointer-get
+          pffi-string->pointer
+          pffi-pointer->string
+          pffi-define
+          pffi-define-callback
           ;pffi-pointer-address
           ;pffi-pointer-dereference
-          ;pffi-string->pointer
-          ;pffi-pointer->string
-          ;pffi-pointer-free
-          ;pffi-pointer?
-          ;pffi-pointer-set!
-          ;pffi-pointer-get
           )
   (cond-expand
     (chibi (include "r7rs-pffi/chibi.scm"))

retropikzel/r7rs-pffi/mosh.scm

@@ -29,9 +29,122 @@
 
 (define pffi-pointer-null
   (lambda ()
-    #f)) ; TODO
+    pointer-null))
 
 (define pffi-pointer-null?
   (lambda (pointer)
-    (if (equal? pointer #f) #t #f))) ; TODO
+    (pointer-null? pointer)))
 
+(define pffi-pointer-allocate
+  (lambda (size)
+    (malloc size)))
+
+(define pffi-pointer?
+  (lambda (object)
+    (pointer? object)))
+
+(define pffi-pointer-free
+  (lambda (pointer)
+    (free pointer)))
+
+(define pffi-pointer-set!
+  (lambda (pointer type offset value)
+    (cond ((equal? type 'int8) (pointer-set-c-int8! pointer offset value))
+          ((equal? type 'uint8) (pointer-set-c-uint8! pointer offset value))
+          ((equal? type 'int16) (pointer-set-c-int16! pointer offset value))
+          ((equal? type 'uint16) (pointer-set-c-uint16! pointer offset value))
+          ((equal? type 'int32) (pointer-set-c-int32! pointer offset value))
+          ((equal? type 'uint32) (pointer-set-c-uint32! pointer offset value))
+          ((equal? type 'int64) (pointer-set-c-int64! pointer offset value))
+          ((equal? type 'uint64) (pointer-set-c-uint64! pointer offset value))
+          ((equal? type 'char) (pointer-set-c-char! pointer offset (char->integer value)))
+          ((equal? type 'short) (pointer-set-c-short! pointer offset value))
+          ((equal? type 'unsigned-short) (pointer-set-c-short! pointer offset value)) ;; FIXME
+          ((equal? type 'int) (pointer-set-c-int! pointer offset value))
+          ((equal? type 'unsigned-int) (pointer-set-c-int! pointer offset value)) ;; FIXME
+          ((equal? type 'long) (pointer-set-c-long! pointer offset value))
+          ((equal? type 'unsigned-long) (pointer-set-c-long! pointer offset value)) ;; FIXME
+          ((equal? type 'float) (pointer-set-c-float! pointer offset value))
+          ((equal? type 'double) (pointer-set-c-double! pointer offset value))
+          ((equal? type 'void) (pointer-set-c-pointer! pointer offset value))
+          ((equal? type 'pointer) (pointer-set-c-pointer! pointer offset value)))))
+
+(define pffi-pointer-get
+  (lambda (pointer type offset)
+    (cond ((equal? type 'int8) (pointer-ref-c-int8 pointer offset))
+          ((equal? type 'uint8) (pointer-ref-c-uint8 pointer offset))
+          ((equal? type 'int16) (pointer-ref-c-int16 pointer offset))
+          ((equal? type 'uint16) (pointer-ref-c-uint16 pointer offset))
+          ((equal? type 'int32) (pointer-ref-c-int32 pointer offset))
+          ((equal? type 'uint32) (pointer-ref-c-uint32 pointer offset))
+          ((equal? type 'int64) (pointer-ref-c-int64 pointer offset))
+          ((equal? type 'uint64) (pointer-ref-c-uint64 pointer offset))
+          ((equal? type 'char) (integer->char (pointer-ref-c-signed-char pointer offset)))
+          ((equal? type 'short) (pointer-ref-c-signed-short pointer offset))
+          ((equal? type 'unsigned-short) (pointer-ref-c-unsigned-short pointer offset))
+          ((equal? type 'int) (pointer-ref-c-signed-int pointer offset))
+          ((equal? type 'unsigned-int) (pointer-ref-c-unsigned-int pointer offset))
+          ((equal? type 'long) (pointer-ref-c-signed-long pointer offset))
+          ((equal? type 'unsigned-long) (pointer-ref-c-unsigned-long pointer offset))
+          ((equal? type 'float) (pointer-ref-c-float pointer offset))
+          ((equal? type 'double) (pointer-ref-c-double pointer offset))
+          ((equal? type 'void) (pointer-ref-c-pointer pointer offset))
+          ((equal? type 'pointer) (pointer-ref-c-pointer pointer offset)))))
+
+(define pffi-string->pointer
+  (lambda (string-content)
+    (let ((pointer (pffi-pointer-allocate (+ (string-length string-content) 1)))
+          (index 0))
+      (string-for-each
+        (lambda (c)
+          (pffi-pointer-set! pointer 'char (* index (pffi-size-of 'char)) c)
+          (set! index (+ index 1)))
+        string-content)
+      pointer)))
+
+(define pffi-pointer->string
+  (lambda (pointer)
+    (pointer->string pointer)))
+
+(define pffi-type->native-type
+  (lambda (type)
+    (cond ((equal? type 'int8) 'int8_t)
+          ((equal? type 'uint8) 'uint8_t)
+          ((equal? type 'int16) 'int16_t)
+          ((equal? type 'uint16) 'uint16_t)
+          ((equal? type 'int32) 'int32_t)
+          ((equal? type 'uint32) 'uint32_t)
+          ((equal? type 'int64) 'int64_t)
+          ((equal? type 'uint64) 'uint64_t)
+          ((equal? type 'char) 'char)
+          ((equal? type 'unsigned-char) '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) 'void*)
+          ((equal? type 'string) 'char*)
+          ((equal? type 'void) 'void)
+          ((equal? type 'callback) 'callback)
+          (else (error "pffi-type->native-type -- No such pffi type" type)))))
+
+(define-syntax pffi-define
+  (syntax-rules ()
+    ((pffi-define scheme-name shared-object c-name return-type argument-types)
+     (define scheme-name
+       (make-c-function shared-object
+                        (pffi-type->native-type return-type)
+                        c-name
+                        (map pffi-type->native-type argument-types))))))
+
+(define-syntax pffi-define-callback
+  (syntax-rules ()
+    ((_ scheme-name return-type argument-types procedure)
+     (define scheme-name
+       (make-c-callback (pffi-type->native-type return-type)
+                        (map pffi-type->native-type argument-types)
+                        procedure)))))

test.scm

@@ -187,7 +187,6 @@
 (debug null-pointer)
 (assert equal? (pffi-pointer-null? null-pointer) #t)
 
-#|
 ;; pffi-pointer-null?
 
 (print-header 'pffi-pointer-null?)
@@ -226,6 +225,7 @@
 (pffi-pointer-free pointer-to-be-freed)
 (debug pointer-to-be-freed)
 
+#|
 ;; pffi-pointer-set! and pffi-pointer-get 1/2
 
 (print-header "pffi-pointer-set! and pffi-pointer-get 1/2")
@@ -270,6 +270,8 @@
 (debug (pffi-pointer-get set-pointer 'double offset))
 (assert = (pffi-pointer-get set-pointer 'double offset) 1.5)
 
+|#
+
 ;; pffi-string->pointer
 
 (print-header 'pffi-string->pointer)
@@ -321,6 +323,7 @@
 (debug (pffi-pointer-get hello-string-pointer 'char 4))
 (assert char=? (pffi-pointer-get hello-string-pointer 'char 4) #\o)
 
+#|
 ;; pffi-pointer-set! and pffi-pointer-get 2/2
 
 (print-header "pffi-pointer-set! and pffi-pointer-get 2/2")
@@ -347,6 +350,8 @@
 (pffi-pointer-set! set-pointer 'pointer offset (pffi-string->pointer string-to-be-set))
 (assert string=? (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset)) "FOOBAR")
 
+|#
+
 ;; pffi-define
 
 (print-header 'pffi-define)
@@ -391,4 +396,3 @@
 (newline)
 
 (exit 0)
-|#