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

Made good progress with the struct interface

This commit is contained in:
retropikzel 2025-01-14 20:43:54 +02:00
parent 0a5883eade
commit ebba1db3f7
2 changed files with 65 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
retropikzel/r7rs-pffi/struct.scm
View File

@ -17,20 +17,35 @@
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 (calculate-struct-size-and-offsets members)
(let* ((size 0)
(largest-member-size 0)
(offsets (map (lambda (member)
(let* ((name (cdr member))
(type (car member))
(type-alignment (pffi-align-of type)))
(when (> (pffi-size-of type) largest-member-size)
(set! largest-member-size (pffi-size-of type)))
(if (or (= size 0)
(= (floor-remainder size type-alignment) 0))
(begin
(set! size (+ size type-alignment))
(list name type (- size type-alignment)))
(begin
(set! size (+ (round-to-next-modulo-of size type-alignment)
type-alignment))
(list name
type
(round-to-next-modulo-of size type-alignment))))))
members)))
(list (cons 'size
(cond-expand
(guile (sizeof (map pffi-type->native-type (map car members))))
(else
(if (= (modulo size largest-member-size) 0)
size
(round-to-next-modulo-of size largest-member-size)))))
(cons 'offsets offsets))))
(define pffi-word-size
(cond-expand
@ -38,6 +53,10 @@
(else 8))) ; 64-bit system
(define (pffi-struct-allocate name members)
(let* ((size (calculate-struct-size (map car members)))
(let* ((size-and-offsets (calculate-struct-size-and-offsets members))
(size (cdr (assoc 'size size-and-offsets)))
(offsets (cdr (assoc 'offsets size-and-offsets)))
(pointer (pffi-pointer-allocate size)))
(write size-and-offsets)
(newline)
(pffi-struct-make name size pointer members)))

31
test.scm
View File

@ -433,6 +433,8 @@
; pffi-struct-allocate
(print-header "pffi-struct")
(define struct1 (pffi-struct-allocate 'test '((int . r) (int . g) (int . b))))
(debug struct1)
(debug (pffi-struct-size struct1))
@ -448,6 +450,35 @@
(debug (pffi-struct-size struct3))
(assert = (pffi-struct-size struct3) 8)
(define struct4 (pffi-struct-allocate 'test '((int8 . r) (pointer . a) (int8 . g) (int . b))))
(debug struct4)
(debug (pffi-struct-size struct4))
(assert = (pffi-struct-size struct4) 24)
(define struct5 (pffi-struct-allocate 'test '((int8 . r) (char . b) (pointer . a) (int8 . g) (int . b))))
(debug struct5)
(debug (pffi-struct-size struct5))
(assert = (pffi-struct-size struct5) 24)
(define struct6 (pffi-struct-allocate 'test '((int8 . r)
(char . b)
(double . c)
(char bb)
(pointer . a)
(float . d)
(pointer . aa)
(int8 . g)
(pointer . aaa)
(int . bbb)
(int . bbbb)
(int . bbbb)
(double . c)
(float . d)
)))
(debug struct6)
(debug (pffi-struct-size struct6))
(assert = (pffi-struct-size struct6) 96)
#|
;; pffi-string->pointer