Working on the C struct interface

Jenkinsfile

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

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

foreign/c/struct.scm

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

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)