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

Working on the C struct interface

This commit is contained in:
retropikzel 2025-08-08 10:30:50 +03:00
parent 83f67de603
commit 8b1f65122a
4 changed files with 141 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Jenkinsfile vendored
View File

@ -1,4 +1,4 @@
def tests = ['primitives', 'array', 'addressof', 'callback']
def tests = ['primitives', 'array', 'struct', 'addressof', 'callback']
pipeline {
agent any

16
foreign/c.sld
View File

@ -281,7 +281,7 @@
;; TODO c-utf32->string
;c-string-length ;; TODO Documentation, Testing
;c-utf8-length ;; TODO ??
;; c-array
make-c-array
@ -289,17 +289,10 @@
c-array-set!
list->c-array
c-array->list
;define-c-array (?)
;pffi-array-allocate;make-c-array
;pffi-array-pointer;c-array-pointer
;pffi-array?;c-array?
;pffi-pointer->array;c-bytevector->array
;pffi-array-get;c-array-get
;pffi-array-set!;c-array-set!
;pffi-list->array;list->c-array
;pffi-array->list;c-array->list
;; c-struct
define-c-struct
c-struct->alist
;pffi-define-struct;define-c-struct
;pffi-struct-pointer;c-struct-bytevector
;pffi-struct-offset-get;c-struct-offset
@ -339,5 +332,4 @@
(include "c/c-bytevectors.scm")
(include "c/pointer.scm")
(include "c/array.scm")
;(include "c/struct.scm")
)
(include "c/struct.scm"))

147
foreign/c/struct.scm
View File

@ -1,4 +1,4 @@
(define-record-type <c-struct>
#;(define-record-type <c-struct>
(c-struct-make c-type size pointer members)
c-struct?
(c-type c-struct:type)
@ -6,9 +6,116 @@
(pointer c-struct:pointer)
(members c-struct:members))
(define round-to-next-modulo-of
(lambda (to-round roundee)
(if (= (modulo to-round roundee) 0)
to-round
(round-to-next-modulo-of (+ to-round 1) roundee))))
(define calculate-struct-members
(lambda (members)
(let*
((size 0)
(largest-member-size 0)
(data (map (lambda (member)
(let* ((name (list-ref member 0))
(type (list-ref member 1))
(accessor (list-ref member 2))
(type-alignment (c-type-align type)))
(when (> (size-of-type type) largest-member-size)
(set! largest-member-size (size-of-type type)))
(if (or (= size 0)
(= (modulo size type-alignment) 0))
(begin
(set! size (+ size type-alignment))
(list name type (- size type-alignment) accessor))
(let ((next-alignment
(round-to-next-modulo-of size type-alignment)))
(set! size (+ next-alignment type-alignment))
(list name type next-alignment accessor)))))
members)))
data)))
(define-syntax define-c-struct
(syntax-rules ()
((_ name c-type members)
((_ name members struct-pointer (field-name field-type accessor modifier) ...)
(begin
(define accessor
(lambda (c-bytevector)
(let ((offset (let ((offset 0)
(before? #t))
(for-each
(lambda (member)
(when (equal? (list-ref member 0) 'field-name)
(set! before? #f))
(when before?
(set! offset
(+ offset
(c-type-align (list-ref member 1))))))
members)
offset)))
(cond
((equal? 'pointer field-type)
(c-bytevector-pointer-ref c-bytevector offset))
((c-type-signed? field-type)
(c-bytevector-sint-ref c-bytevector
offset
(native-endianness)
(c-type-size field-type)))
(else
(c-bytevector-uint-ref c-bytevector
offset
(native-endianness)
(c-type-size field-type)))))))
...
(define modifier
(lambda (c-bytevector value)
(let ((offset (let ((offset 0)
(before? #t))
(for-each
(lambda (member)
(when (equal? (list-ref member 0) 'field-name)
(set! before? #f))
(when before?
(set! offset
(+ offset
(c-type-align (list-ref member 1))))))
members)
offset)))
(cond
((equal? 'pointer field-type)
(c-bytevector-pointer-set! c-bytevector offset value))
((c-type-signed? field-type)
(c-bytevector-sint-set! c-bytevector
offset
value
(native-endianness)
(c-type-size field-type)))
(else
(c-bytevector-uint-set! c-bytevector
offset
value
(native-endianness)
(c-type-size field-type)))))))
...
(define members (calculate-struct-members
(list (list 'field-name field-type accessor) ...)))
(define name
(if (c-null? struct-pointer)
(make-c-bytevector (+ (c-type-size field-type) ...))
struct-pointer))))))
(define c-struct->alist
(lambda (struct-c-bytevector struct-members)
(map (lambda (member)
(cons (list-ref member 0)
(apply (list-ref member 3) (list struct-c-bytevector))))
struct-members)))
#;(define-syntax define-c-struct
(syntax-rules ()
((_ name constructor pred field ...)
(define name
(lambda arguments
(let* ((size-and-offsets (calculate-struct-size-and-offsets members))
@ -21,42 +128,6 @@
(c-type-string (if (string? c-type) c-type (symbol->string c-type))))
(c-struct-make c-type-string size pointer offsets)))))))
(define round-to-next-modulo-of
(lambda (to-round roundee)
(if (= (modulo to-round roundee) 0)
to-round
(round-to-next-modulo-of (+ to-round 1) roundee))))
(define calculate-struct-size-and-offsets
(lambda (members)
(let* ((size 0)
(largest-member-size 0)
(offsets (map (lambda (member)
(let* ((name (cdr member))
(type (car member))
(type-alignment (c-align-of type)))
(when (> (size-of-type type) largest-member-size)
(set! largest-member-size (size-of-type type)))
(if (or (= size 0)
(= (modulo size type-alignment) 0))
(begin
(set! size (+ size type-alignment))
(list name type (- size type-alignment)))
(let ((next-alignment (round-to-next-modulo-of size type-alignment)))
(set! size (+ next-alignment type-alignment))
(list name
type
next-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-struct-make
(lambda (c-type members . pointer)
(for-each

28
tests/structs.scm → tests/struct.scm
View File

@ -74,5 +74,31 @@
;; define-c-struct
(define-c-struct s
s-members
(make-c-null)
(field1 'int t-struct:field1 t-struct:field1!)
(field2 'int t-struct:field2 t-struct:field2!)
(field3 'pointer t-struct:field3 t-struct:field3!)
(field4 'int t-struct:field4 t-struct:field4!))
(define-c-struct test '() '())
(t-struct:field1! s 1)
(t-struct:field2! s 2)
(t-struct:field3! s (make-c-bytevector 32))
(t-struct:field4! s 4)
(write s)
(newline)
(write s-members)
(newline)
(write (t-struct:field1 s))
(newline)
(write (t-struct:field2 s))
(newline)
(write (t-struct:field3 s))
(newline)
(write (t-struct:field4 s))
(newline)
(write (c-struct->alist s s-members))
(newline)