Small improvements here and there

Makefile

@@ -24,8 +24,10 @@ retropikzel/r7rs-pffi/r7rs-pffi-chibi.so: retropikzel/r7rs-pffi/r7rs-pffi-chibi.
 test-chibi: retropikzel/r7rs-pffi/r7rs-pffi-chibi.so libtest.so
 	${CHIBI} test.scm
 
-CHICKEN5=csc -X r7rs -R r7rs -I.
+CHICKEN5=SCMC=csc CSCFLAGS="-I. " compile-r7rs main.scm
-CHICKEN5_LIB=csc -X r7rs -R r7rs -I. -include-path ./retropikzel -s -J
+#CHICKEN5=csc -X r7rs -R r7rs -uses scheme.base -I.
+#CHICKEN5_LIB=csc -X r7rs -R r7rs -uses r7rs -I. -include-path ./retropikzel -s -J
+#CHICKEN5_LIB=csc -X r7rs -R r7rs -uses r7rs -unit retropikzel.r7rs-pffi -include-path ./retropikzel -s -J
 test-chicken5-podman-amd65: clean libtest.so
 	cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld
 	podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/chicken:5 bash -c "cd /workdir && ${CHICKEN5_LIB} retropikzel.r7rs-pffi.sld"
@@ -37,9 +39,10 @@ test-chicken5-docker: clean libtest.so
 	docker run -it -v ${PWD}:/workdir docker.io/schemers/chicken:5 bash -c "cd /workdir && ${CHICKEN5} test.scm && ./test"
 
 test-chicken5: clean libtest.so
-	cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld
+	#cp retropikzel/r7rs-pffi.sld retropikzel.r7rs-pffi.sld
-	${CHICKEN5_LIB} retropikzel.r7rs-pffi.sld
+	#${CHICKEN5_LIB} retropikzel.r7rs-pffi.sld
-	${CHICKEN5} test.scm && ./test
+	${CHICKEN5} test.scm
+	./test
 
 CHICKEN6=csc -I.
 CHICKEN6_LIB=csc -I. -include-path ./retropikzel -s -J

libtest.c

@@ -182,7 +182,7 @@ EXPORT int test_check(struct test* test) {
     assert(test->n == 14);
 }
 
-EXPORT struct test* test_new(struct test* test) {
+EXPORT struct test* test_new() {
     print_offsets();
     struct test* t = malloc(sizeof(struct test));
     t->a = 1;

libtest.h

@@ -1,2 +1,6 @@
-struct test* function(struct test* test);
+void print_string_pointer(char* p);
-
+void print_offsets();
+void check_offset(int member_index, int offset);
+struct test* init_struct(struct test* test);
+int test_check(struct test* test);
+struct test* test_new();

retropikzel/r7rs-pffi.sld

@@ -33,7 +33,7 @@
               pffi-define
               pffi-define-callback)
       (include-shared "r7rs-pffi/r7rs-pffi-chibi"))
-    (chicken5
+    (chicken-5
       (import (scheme base)
               (scheme write)
               (scheme char)
@@ -458,7 +458,7 @@
               pffi-pointer?
               pffi-pointer-free
               pffi-pointer-set!
-              ;pffi-pointer-get
+              pffi-pointer-get
               ;pffi-string->pointer
               ;pffi-pointer->string
               pffi-struct-make
@@ -531,8 +531,8 @@
     (else (error "Unsupported implementation")))
   (cond-expand
     (chibi (include "r7rs-pffi/chibi.scm"))
-    (chicken5 (include "r7rs-pffi/chicken.scm"))
+    (chicken-5 (include "r7rs-pffi/chicken5.scm"))
-    (chicken6 (include "chicken6.scm"))
+    (chicken-6 (include "chicken6.scm"))
     (cyclone (include "r7rs-pffi/cyclone.scm"))
     (gambit (include "r7rs-pffi/gambit.scm"))
     (gauche (include "r7rs-pffi/gauche.scm"))
@@ -548,5 +548,9 @@
     (tr7 (include "r7rs-pffi/tr7.scm"))
     (ypsilon (include "r7rs-pffi/ypsilon.scm"))
     (else #t))
-  (include "r7rs-pffi/struct.scm")
+  (cond-expand
-  (include "r7rs-pffi/main.scm"))
+    (stklos (include "retropikzel/r7rs-pffi/struct.scm")) ; FIXME temporarily for stklos 2.10
+    (else (include "r7rs-pffi/struct.scm")))
+  (cond-expand
+    (stklos (include "retropikzel/r7rs-pffi/main.scm")) ; FIXME temporarily for stklos 2.10
+    (else (include "r7rs-pffi/main.scm"))))

retropikzel/r7rs-pffi/chicken5.scm

@@ -1,5 +1,5 @@
 
-(define pffi-type->native-type
+(define pffi-type->native-type ; Chicken has this procedure in three places
   (lambda (type)
     (cond ((equal? type 'int8) 'byte)
           ((equal? type 'uint8) 'unsigned-byte)
@@ -22,6 +22,7 @@
           ((equal? type 'pointer) 'c-pointer)
           ((equal? type 'void) 'void)
           ((equal? type 'callback) 'c-pointer)
+          ((equal? type 'struct) 'c-pointer)
           (else (error "pffi-type->native-type -- No such pffi type" type)))) )
 
 (define pffi-pointer?
@@ -31,7 +32,7 @@
 (define-syntax pffi-define
   (er-macro-transformer
     (lambda (expr rename compare)
-      (let* ((pffi-type->native-type
+      (let* ((pffi-type->native-type ; Chicken has this procedure in three places
                (lambda (type)
                  (cond ((equal? type 'int8) 'byte)
                        ((equal? type 'uint8) 'unsigned-byte)
@@ -54,6 +55,7 @@
                        ((equal? type 'pointer) 'c-pointer)
                        ((equal? type 'void) 'void)
                        ((equal? type 'callback) 'c-pointer)
+                       ((equal? type 'struct) '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))))))))
@@ -72,7 +74,7 @@
 (define-syntax pffi-define-callback
   (er-macro-transformer
     (lambda (expr rename compare)
-      (let* ((pffi-type->native-type
+      (let* ((pffi-type->native-type ; Chicken has this procedure in three places
                (lambda (type)
                  (cond ((equal? type 'int8) 'byte)
                        ((equal? type 'uint8) 'unsigned-byte)
@@ -95,6 +97,7 @@
                        ((equal? type 'pointer) 'c-pointer)
                        ((equal? type 'void) 'void)
                        ((equal? type 'callback) 'c-pointer)
+                       ((equal? type 'struct) '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)))))))
@@ -246,5 +249,5 @@
 
 (define pffi-struct-dereference
   (lambda (struct)
-    (pffi-struct-pointer struct)))
+    (pffi-pointer-address (pffi-struct-pointer struct))))
 

retropikzel/r7rs-pffi/main.scm

@@ -1,5 +1,5 @@
 (cond-expand
-  ((or chicken5 chicken6)
+  ((or chicken-5 chicken-6)
    (define-syntax pffi-init
      (er-macro-transformer
        (lambda (expr rename compare)

retropikzel/r7rs-pffi/stklos.scm

@@ -21,6 +21,7 @@
           ((equal? type 'pointer) :pointer)
           ((equal? type 'string) :string)
           ((equal? type 'void) :void)
+          ((equal? type 'struct) :void)
           (else (error "pffi-type->native-type -- No such pffi type" type)))))
 
 (define pffi-pointer?
@@ -39,8 +40,7 @@
 
 (define pffi-define-callback
   (lambda ()
-    (error "Not implemented")
+    (error "Not implemented")))
-    ))
 
 ; If youre reading this, this is just a temp hack. Dont judge me :D
 (define pffi-size-of
@@ -76,7 +76,7 @@
   (lambda ()
     (let ((p (allocate-bytes 0)))
       (free-bytes p)
-       p)))
+      p)))
 
 (define pffi-string->pointer
   (lambda (string-content)
@@ -103,9 +103,7 @@
 
 (define pffi-pointer-set!
   (lambda (pointer type offset value)
-    (let ((null-pointer (pffi-pointer-null))
+    (error "Not implemented")))
-          (offset-address (cpointer-data pointer)))
-      (cpointer-data-set! null-pointer offset-address))))
 
 (define pffi-pointer-get
   (lambda (pointer type offset)

retropikzel/r7rs-pffi/struct.scm

@@ -47,7 +47,8 @@
                       (round-to-next-modulo-of size largest-member-size)))))
           (cons 'offsets offsets))))
 
-(define (pffi-struct-make name members . pointer)
+(define pffi-struct-make
+  (lambda (name members . pointer)
   (for-each
     (lambda (member)
       (when (not (pair? member))
@@ -62,7 +63,7 @@
          (offsets (cdr (assoc 'offsets size-and-offsets)))
          (pointer (if (null? pointer) (pffi-pointer-allocate size) (car pointer)))
          (name (if (string? name) name (symbol->string name))))
-    (struct-make name size pointer offsets)))
+    (struct-make name size pointer offsets))))
 
 (define (pffi-struct-offset-get struct member-name)
   (when (not (assoc member-name (pffi-struct-members struct)))