From: Javier Sancho <jsf@jsancho.org>
Date: Wed, 25 Dec 2019 16:08:09 +0000 (+0100)
Subject: Foreign records (in C) (WIP)
X-Git-Url: https://git.jsancho.org/?a=commitdiff_plain;h=326fe276421f5b7688931563762d26cbeb74c99e;p=guile-irrlicht.git

Foreign records (in C) (WIP)
---

diff --git a/irrlicht/util.scm b/irrlicht/util.scm
index afc3cb8..ecd21f6 100644
--- a/irrlicht/util.scm
+++ b/irrlicht/util.scm
@@ -20,9 +20,12 @@
 
 (define-module (irrlicht util)
   #:use-module (system foreign)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
   #:export (bool->integer
             integer->bool
-            define-foreign))
+            define-foreign
+            define-foreign-record-type))
 
 (define (bool->integer var)
   (if var 1 0))
@@ -41,3 +44,69 @@
 (define-syntax-rule (define-foreign name return-type func-name arg-types)
   (define-public name
     (irrlicht-func return-type func-name arg-types)))
+
+;; foreign struct record type
+(define-record-type standard-foreign-record-type
+  (make-foreign-record-type name types fields)
+  foreign-record-type?
+  (name foreign-record-type-name)
+  (types foreign-record-type-types)
+  (fields foreign-record-type-fields))
+
+(define-record-type foreign-record
+  (make-foreign-record type pointer)
+  foreign-record?
+  (type foreign-record-type)
+  (pointer foreign-record-pointer set-foreign-record-pointer!))
+
+(set-record-type-printer! foreign-record
+  (lambda (record port)
+    (format port "#<~a" (foreign-record-type-name (foreign-record-type record)))
+    (let* ((pointer (foreign-record-pointer record))
+           (record-type (foreign-record-type record))
+           (types (foreign-record-type-types record-type))
+           (fields (foreign-record-type-fields record-type))
+           (values (parse-c-struct pointer types)))
+      (for-each (lambda (field value)
+                  (format port " ~a: ~a" field value))
+                fields
+                values))
+    (format port ">")))
+
+(define-syntax define-foreign-record-type
+  (lambda (x)
+    (define (field-names field-specs)
+      (map (lambda (field-spec)
+             (syntax-case field-spec ()
+               ((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))
+    (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 ...))))
+         #'(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)))))
+             (export name)
+             (export make-name)
+             (export predicate?)))))))