From 8b1f65122a568942a235ea2865c277d9f12e4f72 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Fri, 8 Aug 2025 10:30:50 +0300 Subject: [PATCH] Working on the C struct interface --- Jenkinsfile | 2 +- foreign/c.sld | 16 +--- foreign/c/struct.scm | 147 ++++++++++++++++++++++-------- tests/{structs.scm => struct.scm} | 28 +++++- 4 files changed, 141 insertions(+), 52 deletions(-) rename tests/{structs.scm => struct.scm} (72%) diff --git a/Jenkinsfile b/Jenkinsfile index 804e729..106d143 100644 --- a/Jenkinsfile +++ b/Jenkinsfile @@ -1,4 +1,4 @@ -def tests = ['primitives', 'array', 'addressof', 'callback'] +def tests = ['primitives', 'array', 'struct', 'addressof', 'callback'] pipeline { agent any diff --git a/foreign/c.sld b/foreign/c.sld index ed97dfe..ecdd752 100644 --- a/foreign/c.sld +++ b/foreign/c.sld @@ -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")) diff --git a/foreign/c/struct.scm b/foreign/c/struct.scm index afa4f1f..e685e7e 100644 --- a/foreign/c/struct.scm +++ b/foreign/c/struct.scm @@ -1,4 +1,4 @@ -(define-record-type +#;(define-record-type (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 diff --git a/tests/structs.scm b/tests/struct.scm similarity index 72% rename from tests/structs.scm rename to tests/struct.scm index ca5ecd5..49227ba 100644 --- a/tests/structs.scm +++ b/tests/struct.scm @@ -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)