From: Javier Sancho <jsf@jsancho.org>
Date: Fri, 27 Dec 2019 12:38:29 +0000 (+0100)
Subject: Foreign records (in C)
X-Git-Url: https://git.jsancho.org/?a=commitdiff_plain;h=f3a560cc144b7878256e18ee69c99767485a6111;p=guile-irrlicht.git

Foreign records (in C)
---

diff --git a/irrlicht/util.scm b/irrlicht/util.scm
index ecd21f6..488ea33 100644
--- a/irrlicht/util.scm
+++ b/irrlicht/util.scm
@@ -20,6 +20,7 @@
 
 (define-module (irrlicht util)
   #:use-module (system foreign)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
   #:export (bool->integer
@@ -81,32 +82,77 @@
                ((name type getter) #'name)
                ((name type getter setter) #'name)))
            field-specs))
+
     (define (field-types field-specs)
       (map (lambda (field-spec)
              (syntax-case field-spec ()
                ((name type getter) #'type)
                ((name type getter setter) #'type)))
            field-specs))
+
+    (define (field-getters field-specs)
+      (map (lambda (field-spec field-id)
+             (syntax-case field-spec ()
+               ((name type getter) (list #'getter field-id))
+               ((name type getter setter) (list #'getter field-id))))
+           field-specs
+           (iota (length field-specs))))
+
+    (define (field-setters field-specs)
+      (filter-map (lambda (field-spec field-id)
+                    (syntax-case field-spec ()
+                      ((name type getter) #f)
+                      ((name type getter setter) (list #'setter field-id))))
+                  field-specs
+                  (iota (length field-specs))))
+
     (syntax-case x ()
       ((_ name (make-name make-arg ...) predicate? field-spec ...)
        (with-syntax (((type-id ...) (field-types #'(field-spec ...)))
-                     ((field-name ...) (field-names #'(field-spec ...))))
+                     ((field-name ...) (field-names #'(field-spec ...)))
+                     (((getter getter-id) ...) (field-getters #'(field-spec ...)))
+                     (((setter setter-id) ...) (field-setters #'(field-spec ...))))
          #'(begin
              (define name
                (make-foreign-record-type
                 'name
                 (list type-id ...)
                 (list 'field-name ...)))
+
              (define (make-name make-arg ...)
                (let* ((types (foreign-record-type-types name))
                       (c-struct-pointer (make-c-struct types (list make-arg ...))))
                  (make-foreign-record name c-struct-pointer)))
+
              (define (predicate? record)
                (and
                 (foreign-record? record)
                 (let* ((record-type (foreign-record-type record))
                        (type-name (foreign-record-type-name record-type)))
                   (equal? type-name (foreign-record-type-name name)))))
+
+             (define (getter record)
+               (let* ((pointer (foreign-record-pointer record))
+                      (record-type (foreign-record-type record))
+                      (types (foreign-record-type-types record-type))
+                      (values (parse-c-struct pointer types)))
+                 (list-ref values getter-id)))
+             ...
+
+             (define (setter record new-value)
+               (let* ((pointer (foreign-record-pointer record))
+                      (record-type (foreign-record-type record))
+                      (types (foreign-record-type-types record-type))
+                      (values (parse-c-struct pointer types)))
+                 (list-set! values setter-id new-value)
+                 (set-foreign-record-pointer! record (make-c-struct types values))
+                 new-value))
+             ...
+
              (export name)
              (export make-name)
-             (export predicate?)))))))
+             (export predicate?)
+             (export getter)
+             ...
+             (export setter)
+             ...))))))