Started adding struct utilities

Makefile

@@ -1,4 +1,5 @@
 CC=gcc
+DOCKER=docker run -it -v ${PWD}:/workdir
 
 CHIBI=chibi-scheme -A .
 test-chibi-podman-amd64:
@@ -10,7 +11,13 @@ retropikzel/r7rs-pffi/r7rs-pffi-chibi.c:
 	chibi-ffi retropikzel/r7rs-pffi/r7rs-pffi-chibi.stub
 
 retropikzel/r7rs-pffi/r7rs-pffi-chibi.so: retropikzel/r7rs-pffi/r7rs-pffi-chibi.c
-	${CC} -o retropikzel/r7rs-pffi/r7rs-pffi-chibi.so -fPIC -shared retropikzel/r7rs-pffi/r7rs-pffi-chibi.c -lchibi-scheme -lffi
+	${CC} -o retropikzel/r7rs-pffi/r7rs-pffi-chibi.so \
+		-fPIC \
+		-shared retropikzel/r7rs-pffi/r7rs-pffi-chibi.c \
+		-lchibi-scheme \
+		-lffi \
+		-L${HOME}/.scman/chibi/lib \
+		-I${HOME}/.scman/chibi/include
 
 test-chibi: retropikzel/r7rs-pffi/r7rs-pffi-chibi.so
 	${CHIBI} test.scm
@@ -87,9 +94,9 @@ test-kawa-podman-amd64:
 test-kawa:
 	${KAWA} test.scm
 
-LARCENY=larceny -r7 -I . 
+LARCENY=larceny -r7 -I .
-test-larceny-podman-amd64:
+test-larceny-docker:
-	podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/larceny:latest bash -c "cd /workdir && ${LARCENY} test.scm"
+	${DOCKER} schemers/larceny:latest bash -c "cd /workdir && ${LARCENY} test.scm"
 
 test-larceny:
 	${LARCENY} test.scm

retropikzel/r7rs-pffi.sld

@@ -11,6 +11,7 @@
               (chibi))
       (export pffi-init
               pffi-size-of
+              pffi-align-of
               pffi-shared-object-auto-load
               pffi-shared-object-load
               pffi-pointer-null
@@ -22,6 +23,9 @@
               pffi-pointer-get
               pffi-string->pointer
               pffi-pointer->string
+              pffi-struct-allocate
+              pffi-struct-size
+              pffi-struct-pointer
               pffi-define
               ;pffi-define-callback
               ;pffi-pointer-address
@@ -41,6 +45,7 @@
               (chicken random))
       (export pffi-init
               pffi-size-of
+              pffi-align-of
               pffi-shared-object-auto-load
               pffi-shared-object-load
               pffi-pointer-null
@@ -52,6 +57,9 @@
               pffi-pointer-get
               pffi-string->pointer
               pffi-pointer->string
+              pffi-struct-allocate
+              pffi-struct-size
+              pffi-struct-pointer
               pffi-define
               pffi-define-callback
               pffi-pointer-address
@@ -67,6 +75,7 @@
               (scheme cyclone primitives))
       (export pffi-init
               pffi-size-of
+              pffi-align-of
               pffi-shared-object-auto-load
               pffi-shared-object-load
               pffi-pointer-null
@@ -78,6 +87,9 @@
               pffi-pointer-get
               pffi-string->pointer
               pffi-pointer->string
+              pffi-struct-allocate
+              pffi-struct-size
+              pffi-struct-pointer
               pffi-define
               ;pffi-define-callback
               ;pffi-pointer-address
@@ -92,6 +104,7 @@
               (only (gambit) c-declare c-lambda c-define))
       (export pffi-init
               pffi-size-of
+              pffi-align-of
               pffi-shared-object-auto-load
               pffi-shared-object-load
               ;pffi-pointer-null
@@ -103,6 +116,9 @@
               ;pffi-pointer-get
               ;pffi-string->pointer
               ;pffi-pointer->string
+              pffi-struct-allocate
+              pffi-struct-size
+              pffi-struct-pointer
               ;pffi-define
               ;pffi-define-callback
               ;pffi-pointer-address
@@ -116,6 +132,7 @@
               (scheme process-context))
       (export pffi-init
               ;pffi-size-of
+              pffi-align-of
               ;pffi-shared-object-auto-load
               ;pffi-shared-object-load
               ;pffi-pointer-null
@@ -127,6 +144,9 @@
               ;pffi-pointer-get
               ;pffi-string->pointer
               ;pffi-pointer->string
+              pffi-struct-allocate
+              pffi-struct-size
+              pffi-struct-pointer
               ;pffi-define
               ;pffi-define-callback
               ;pffi-pointer-address
@@ -140,6 +160,7 @@
               (scheme process-context))
       (export pffi-init
               ;pffi-size-of
+              ;pffi-align-of
               ;pffi-shared-object-auto-load
               ;pffi-shared-object-load
               ;pffi-pointer-null
@@ -151,6 +172,9 @@
               ;pffi-pointer-get
               ;pffi-string->pointer
               ;pffi-pointer->string
+              pffi-struct-allocate
+              pffi-struct-size
+              pffi-struct-pointer
               ;pffi-define
               ;pffi-define-callback
               ;pffi-pointer-address
@@ -167,6 +191,7 @@
               (system foreign-library))
       (export pffi-init
               pffi-size-of
+              pffi-align-of
               pffi-shared-object-auto-load
               pffi-shared-object-load
               pffi-pointer-null
@@ -178,6 +203,9 @@
               pffi-pointer-get
               pffi-string->pointer
               pffi-pointer->string
+              pffi-struct-allocate
+              pffi-struct-size
+              pffi-struct-pointer
               pffi-define
               pffi-define-callback
               pffi-pointer-address
@@ -190,6 +218,7 @@
               (scheme process-context))
       (export pffi-init
               pffi-size-of
+              pffi-align-of
               pffi-shared-object-auto-load
               pffi-shared-object-load
               pffi-pointer-null
@@ -201,6 +230,9 @@
               pffi-pointer-get
               pffi-string->pointer
               pffi-pointer->string
+              pffi-struct-allocate
+              pffi-struct-size
+              pffi-struct-pointer
               pffi-define
               ;pffi-define-callback
               ;pffi-pointer-address
@@ -219,6 +251,7 @@
               )
       (export pffi-init
               ;pffi-size-of
+              ;pffi-align-of
               ;pffi-shared-object-auto-load
               ;pffi-shared-object-load
               ;pffi-pointer-null
@@ -230,6 +263,9 @@
               ;pffi-pointer-get
               ;pffi-string->pointer
               ;pffi-pointer->string
+              pffi-struct-allocate
+              pffi-struct-size
+              pffi-struct-pointer
               ;pffi-define
               ;pffi-define-callback
               ;pffi-pointer-address
@@ -245,6 +281,7 @@
               (mosh ffi))
       (export pffi-init
               pffi-size-of
+              pffi-align-of
               pffi-shared-object-auto-load
               pffi-shared-object-load
               pffi-pointer-null
@@ -256,6 +293,9 @@
               pffi-pointer-get
               pffi-string->pointer
               pffi-pointer->string
+              pffi-struct-allocate
+              pffi-struct-size
+              pffi-struct-pointer
               pffi-define
               pffi-define-callback
               ;pffi-pointer-address
@@ -274,6 +314,7 @@
               (ffi vector))
       (export pffi-init
               pffi-size-of
+              pffi-align-of
               pffi-shared-object-auto-load
               pffi-shared-object-load
               pffi-pointer-null
@@ -285,6 +326,9 @@
               pffi-pointer-get
               pffi-string->pointer
               pffi-pointer->string
+              pffi-struct-allocate
+              pffi-struct-size
+              pffi-struct-pointer
               pffi-define
               pffi-define-callback
               pffi-pointer-address
@@ -299,6 +343,7 @@
               (sagittarius))
       (export pffi-init
               pffi-size-of
+              pffi-align-of
               pffi-shared-object-auto-load
               pffi-shared-object-load
               pffi-pointer-null
@@ -310,6 +355,9 @@
               pffi-pointer-get
               pffi-string->pointer
               pffi-pointer->string
+              pffi-struct-allocate
+              pffi-struct-size
+              pffi-struct-pointer
               pffi-define
               pffi-define-callback
               pffi-pointer-address
@@ -322,6 +370,7 @@
               (scheme process-context))
       (export pffi-init
               ;pffi-size-of
+              ;pffi-align-of
               ;pffi-shared-object-auto-load
               ;pffi-shared-object-load
               ;pffi-pointer-null
@@ -333,6 +382,9 @@
               ;pffi-pointer-get
               ;pffi-string->pointer
               ;pffi-pointer->string
+              pffi-struct-allocate
+              pffi-struct-size
+              pffi-struct-pointer
               ;pffi-define
               ;pffi-define-callback
               ;pffi-pointer-address
@@ -347,6 +399,7 @@
               (stklos))
       (export pffi-init
               pffi-size-of
+              pffi-align-of
               pffi-shared-object-auto-load
               pffi-shared-object-load
               pffi-pointer-null
@@ -354,10 +407,13 @@
               pffi-pointer-allocate
               pffi-pointer?
               pffi-pointer-free
-              ;pffi-pointer-set!
+              pffi-pointer-set!
               ;pffi-pointer-get
               ;pffi-string->pointer
               ;pffi-pointer->string
+              pffi-struct-allocate
+              pffi-struct-size
+              pffi-struct-pointer
               ;pffi-define
               ;pffi-define-callback
               ;pffi-pointer-address
@@ -371,6 +427,7 @@
               (scheme process-context))
       (export pffi-init
               ;pffi-size-of
+              ;pffi-align-of
               ;pffi-shared-object-auto-load
               ;pffi-shared-object-load
               ;pffi-pointer-null
@@ -382,6 +439,9 @@
               ;pffi-pointer-get
               ;pffi-string->pointer
               ;pffi-pointer->string
+              pffi-struct-allocate
+              pffi-struct-size
+              pffi-struct-pointer
               ;pffi-define
               ;pffi-define-callback
               ;pffi-pointer-address
@@ -394,24 +454,29 @@
               (scheme file)
               (scheme process-context))
       (export ;pffi-init
-        ;pffi-size-of
+              ;pffi-size-of
-        ;pffi-shared-object-auto-load
+              ;pffi-align-of
-        ;pffi-shared-object-load
+              ;pffi-shared-object-auto-load
-        ;pffi-pointer-null
+              ;pffi-shared-object-load
-        ;pffi-pointer-null?
+              ;pffi-pointer-null
-        ;pffi-pointer-allocate
+              ;pffi-pointer-null?
-        ;pffi-pointer?
+              ;pffi-pointer-allocate
-        ;pffi-pointer-free
+              ;pffi-pointer?
-        ;pffi-pointer-set!
+              ;pffi-pointer-free
-        ;pffi-pointer-get
+              ;pffi-pointer-set!
-        ;pffi-string->pointer
+              ;pffi-pointer-get
-        ;pffi-pointer->string
+              ;pffi-string->pointer
-        ;pffi-define
+              ;pffi-pointer->string
-        ;pffi-define-callback
+              pffi-struct-allocate
-        ;pffi-pointer-address
+              pffi-struct-size
-        ;pffi-pointer-dereference
+              pffi-struct-pointer
+              ;pffi-define
+              ;pffi-define-callback
+              ;pffi-pointer-address
+              ;pffi-pointer-dereference
         ))
     (else (error "Unsupported implementation")))
+  (include "r7rs-pffi/struct.scm")
   (cond-expand
     (chibi (include "r7rs-pffi/chibi.scm"))
     (chicken (include "r7rs-pffi/chicken.scm"))
@@ -430,6 +495,4 @@
     (tr7 (include "r7rs-pffi/tr7.scm"))
     (ypsilon (include "r7rs-pffi/ypsilon.scm"))
     (else #t))
-  (cond-expand
+  (include "r7rs-pffi/main.scm"))
-    (stklos (include "retropikzel/r7rs-pffi/main.scm"))
-    (else (include "r7rs-pffi/main.scm"))))

retropikzel/r7rs-pffi/stklos.scm

@@ -107,14 +107,7 @@
   (lambda (pointer type offset value)
     (let ((null-pointer (pffi-pointer-null))
           (offset-address (cpointer-data pointer)))
-      (cpointer-data-set! null-pointer offset-address)
+      (cpointer-data-set! null-pointer offset-address))))
-      (display "HERE")
-      (newline)
-      (write null-pointer)
-      (newline)
-      (exit)
-    ;(error "Not implemented")
-    )))
 
 (define pffi-pointer-get
   (lambda (pointer type offset)

retropikzel/r7rs-pffi/struct.scm

@@ -0,0 +1,43 @@
+(define-record-type <pffi-struct>
+  (pffi-struct-make name size pointer members)
+  pffi-struct?
+  (name pffi-struct-name)
+  (size pffi-struct-size)
+  (pointer pffi-struct-pointer)
+  (members pffi-struct-members))
+
+(define pffi-align-of
+  (lambda (type)
+    (cond-expand
+      (guile (alignof (pffi-type->native-type type)))
+      (else (pffi-size-of type)))))
+
+(define (round-to-next-modulo-of to-round roundee)
+  (if (= (floor-remainder to-round roundee) 0)
+    to-round
+    (round-to-next-modulo-of (+ to-round 1) roundee)))
+
+(define (calculate-struct-size types)
+  (cond-expand
+    (guile (sizeof (map pffi-type->native-type types)))
+    (else
+      (let ((size 0))
+        (for-each
+          (lambda (type)
+            (let ((type-alignment (pffi-align-of type)))
+              (if (or (= size 0)
+                      (= (floor-remainder size type-alignment) 0))
+                (set! size (+ size type-alignment))
+                (set! size (+ (round-to-next-modulo-of size type-alignment) type-alignment)))))
+          types)
+        size))))
+
+(define pffi-word-size
+  (cond-expand
+    (larceny 4) ; 32-bit system
+    (else 8))) ; 64-bit system
+
+(define (pffi-struct-allocate name members)
+  (let* ((size (calculate-struct-size (map car members)))
+         (pointer (pffi-pointer-allocate size)))
+    (pffi-struct-make name size pointer members)))

test.scm

@@ -191,6 +191,144 @@
     (assert equal? (number? size-pointer) #t)
     (assert = size-pointer 8)))
 
+;; pffi-align-of
+
+(print-header 'pffi-align-of)
+
+(define align-int8 (pffi-align-of 'int8))
+(debug align-int8)
+(assert equal? (number? align-int8) #t)
+(assert = align-int8 1)
+
+(define align-uint8 (pffi-align-of 'uint8))
+(debug align-uint8)
+(assert equal? (number? align-uint8) #t)
+(assert = align-uint8 1)
+
+(assert equal? (number? (pffi-align-of 'uint8)) #t)
+(define align-int16 (pffi-align-of 'int16))
+(debug align-int16)
+(assert equal? (number? align-int16) #t)
+(assert = align-int16 2)
+
+(assert equal? (number? (pffi-align-of 'int16)) #t)
+(define align-uint16 (pffi-align-of 'uint16))
+(debug align-uint16)
+(assert equal? (number? align-uint16) #t)
+(assert = align-uint16 2)
+
+(assert equal? (number? (pffi-align-of 'uint16)) #t)
+(define align-int32 (pffi-align-of 'int32))
+(debug align-int32)
+(assert equal? (number? align-int32) #t)
+(assert = align-int32 4)
+
+(assert equal? (number? (pffi-align-of 'int32)) #t)
+(define align-uint32 (pffi-align-of 'uint32))
+(debug align-uint32)
+(assert equal? (number? align-uint32) #t)
+(assert = align-uint32 4)
+
+(assert equal? (number? (pffi-align-of 'uint32)) #t)
+(define align-int64 (pffi-align-of 'int64))
+(debug align-int64)
+(assert equal? (number? align-int64) #t)
+(assert = align-int64 8)
+
+(assert equal? (number? (pffi-align-of 'int64)) #t)
+(define align-uint64 (pffi-align-of 'uint64))
+(debug align-uint64)
+(assert equal? (number? align-uint64) #t)
+(assert = align-uint64 8)
+
+(assert equal? (number? (pffi-align-of 'uint64)) #t)
+(define align-char (pffi-align-of 'char))
+(debug align-char)
+(assert equal? (number? align-char) #t)
+(assert = align-char 1)
+
+(assert equal? (number? (pffi-align-of 'char)) #t)
+(define align-unsigned-char (pffi-align-of 'unsigned-char))
+(debug align-unsigned-char)
+(assert equal? (number? align-unsigned-char) #t)
+(assert = align-unsigned-char 1)
+
+(assert equal? (number? (pffi-align-of 'unsigned-char)) #t)
+(define align-short (pffi-align-of 'short))
+(debug align-short)
+(assert equal? (number? align-short) #t)
+(assert = align-short 2)
+
+(assert equal? (number? (pffi-align-of 'short)) #t)
+(define align-unsigned-short (pffi-align-of 'unsigned-short))
+(debug align-unsigned-short)
+(assert equal? (number? align-unsigned-short) #t)
+(assert = align-unsigned-short 2)
+
+(assert equal? (number? (pffi-align-of 'unsigned-short)) #t)
+(define align-int (pffi-align-of 'int))
+(debug align-int)
+(assert equal? (number? align-int) #t)
+(assert = align-int 4)
+
+(assert equal? (number? (pffi-align-of 'int)) #t)
+(define align-unsigned-int (pffi-align-of 'unsigned-int))
+(debug align-unsigned-int)
+(assert equal? (number? align-unsigned-int) #t)
+(assert = align-unsigned-int 4)
+
+(cond-expand
+  (larceny ;; Works on 32 bit mode
+    (assert equal? (number? (pffi-align-of 'long)) #t)
+    (define align-long (pffi-align-of 'long))
+    (debug align-long)
+    (assert equal? (number? align-long) #t)
+    (assert = align-long 4))
+  (else
+    (assert equal? (number? (pffi-align-of 'long)) #t)
+    (define align-long (pffi-align-of 'long))
+    (debug align-long)
+    (assert equal? (number? align-long) #t)
+    (assert = align-long 8)))
+
+(cond-expand
+  (larceny ;; Works on 32 bit mode
+    (assert equal? (number? (pffi-align-of 'unsigned-long)) #t)
+    (define align-unsigned-long (pffi-align-of 'unsigned-long))
+    (debug align-unsigned-long)
+    (assert equal? (number? align-unsigned-long) #t)
+    (assert = align-unsigned-long 4))
+  (else
+    (assert equal? (number? (pffi-align-of 'long)) #t)
+    (define align-unsigned-long (pffi-align-of 'unsigned-long))
+    (debug align-unsigned-long)
+    (assert equal? (number? align-unsigned-long) #t)
+    (assert = align-unsigned-long 8)))
+
+(assert equal? (number? (pffi-align-of 'float)) #t)
+(define align-float (pffi-align-of 'float))
+(debug align-float)
+(assert equal? (number? align-float) #t)
+(assert = align-float 4)
+
+(assert equal? (number? (pffi-align-of 'double)) #t)
+(define align-double (pffi-align-of 'double))
+(debug align-double)
+(assert equal? (number? align-double) #t)
+(assert = align-double 8)
+
+(cond-expand
+  (larceny ;; Works on 32 bit mode
+    (define align-pointer (pffi-align-of 'pointer))
+    (debug align-pointer)
+    (assert equal? (number? align-pointer) #t)
+    (assert = align-pointer 4))
+  (else
+    (define align-pointer (pffi-align-of 'pointer))
+    (debug align-pointer)
+    (assert equal? (number? align-pointer) #t)
+    (assert = align-pointer 8)))
+
 ;; pffi-shared-object-auto-load
 
 (print-header 'pffi-shared-object-auto-load)
@@ -202,7 +340,6 @@
 
 (debug libc-stdlib)
 
-#|
 ;; pffi-pointer-null
 
 (print-header 'pffi-pointer-null)
@@ -294,6 +431,24 @@
 (debug (pffi-pointer-get set-pointer 'double offset))
 (assert = (pffi-pointer-get set-pointer 'double offset) 1.5)
 
+; pffi-struct-allocate
+
+(define struct1 (pffi-struct-allocate 'test '((int . r) (int . g) (int . b))))
+(debug struct1)
+(debug (pffi-struct-size struct1))
+(assert = (pffi-struct-size struct1) 12)
+
+(define struct2 (pffi-struct-allocate 'test '((int8 . r) (int8 . g) (int . b))))
+(debug struct2)
+(debug (pffi-struct-size struct2))
+(assert = (pffi-struct-size struct2) 8)
+
+(define struct3 (pffi-struct-allocate 'test '((int8 . r) (int8 . g) (int . b))))
+(debug struct3)
+(debug (pffi-struct-size struct3))
+(assert = (pffi-struct-size struct3) 8)
+
+#|
 ;; pffi-string->pointer
 
 (print-header 'pffi-string->pointer)