Retropikzel
/
foreign-c
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Started adding struct utilities

This commit is contained in:
retropikzel 2025-01-14 19:51:24 +02:00
parent e6fd016242
commit 0a5883eade
5 changed files with 294 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
Makefile
View File

@ -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
@ -88,8 +95,8 @@ test-kawa:
${KAWA} test.scm
LARCENY=larceny -r7 -I .
test-larceny-podman-amd64:
podman run --arch=amd64 -it -v ${PWD}:/workdir docker.io/schemers/larceny:latest bash -c "cd /workdir && ${LARCENY} test.scm"
test-larceny-docker:
${DOCKER} schemers/larceny:latest bash -c "cd /workdir && ${LARCENY} test.scm"
test-larceny:
${LARCENY} test.scm

103
retropikzel/r7rs-pffi.sld
View File

@ -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-shared-object-auto-load
;pffi-shared-object-load
;pffi-pointer-null
;pffi-pointer-null?
;pffi-pointer-allocate
;pffi-pointer?
;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-size-of
;pffi-align-of
;pffi-shared-object-auto-load
;pffi-shared-object-load
;pffi-pointer-null
;pffi-pointer-null?
;pffi-pointer-allocate
;pffi-pointer?
;pffi-pointer-free
;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
;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
(stklos (include "retropikzel/r7rs-pffi/main.scm"))
(else (include "r7rs-pffi/main.scm"))))
(include "r7rs-pffi/main.scm"))

9
retropikzel/r7rs-pffi/stklos.scm
View File

@ -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)
(display "HERE")
(newline)
(write null-pointer)
(newline)
(exit)
;(error "Not implemented")
)))
(cpointer-data-set! null-pointer offset-address))))
(define pffi-pointer-get
(lambda (pointer type offset)

43
retropikzel/r7rs-pffi/struct.scm Normal file
View File

@ -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)))

157
test.scm
View File

@ -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)