Improve foreign records declaration

diff --git a/irrlicht/device.scm b/irrlicht/device.scm
index 25ec8ca78bf0328711471b04a2f3df3660fcb17e..04b3648e07913f8a689690354d64ff9610c99169 100644 (file)
--- a/irrlicht/device.scm
+++ b/irrlicht/device.scm
@@ -23,6 +23,7 @@
   #:use-module (system foreign)
   #:use-module ((irrlicht bindings) #:prefix ffi:)
   #:use-module ((irrlicht bindings video) #:prefix ffi-video:)
+  #:use-module (irrlicht dimension2d)
   #:use-module (irrlicht util)
   #:export (create-device
             get-cursor-control
@@ -37,7 +38,7 @@
 
 (define* (create-device #:key
                         (device-type 'software)
-                        (window-size '(640 480))
+                        (window-size (make-dimension2d 640 480))
                         (bits 16)
                         (fullscreen #f)
                         (stencilbuffer #f)
@@ -49,9 +50,10 @@
                        ('direct3d8 ffi-video:EDT_DIRECT3D8)
                        ('direct3d9 ffi-video:EDT_DIRECT3D9)
                        ('opengl ffi-video:EDT_OPENGL)
-                       ('count ffi-video:EDT_COUNT)))
-        (wsize (foreign-record-pointer window-size)))
-    (let ((device (ffi:create-device driver wsize bits
+                       ('count ffi-video:EDT_COUNT))))
+    (let ((device (ffi:create-device driver
+                                     (dimension2d-pointer window-size)
+                                     bits
                                      (bool->integer fullscreen)
                                      (bool->integer stencilbuffer)
                                      (bool->integer vsync))))

diff --git a/irrlicht/dimension2d.scm b/irrlicht/dimension2d.scm
index 7eb8cfd63231ddec2c2d029532ef52daead3e28d..91de9a4a57c5b83c8623dc33202b2fdc8bb4ccad 100644 (file)
--- a/irrlicht/dimension2d.scm
+++ b/irrlicht/dimension2d.scm
@@ -24,6 +24,7 @@
   #:export (dimension2d
             make-dimension2d
             dimension2d?
+            dimension2d-pointer
             dimension2d-width
             dimension2d-height))
 
@@ -31,5 +32,6 @@
 (define-foreign-record-type dimension2d
   (make-dimension2d width height)
   dimension2d?
+  dimension2d-pointer
   (width uint32 dimension2d-width)
   (height uint32 dimension2d-height))

diff --git a/irrlicht/util.scm b/irrlicht/util.scm
index 9110be9fd53a3a311e394bf9feb2e0951b8e13f0..e7c8641026b23a9b93dd95d55f6751ff546de9dd 100644 (file)
--- a/irrlicht/util.scm
+++ b/irrlicht/util.scm
@@ -21,13 +21,11 @@
 (define-module (irrlicht util)
   #:use-module (system foreign)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-9)
-  #:use-module (srfi srfi-9 gnu)
+  #:use-module (rnrs bytevectors)
   #:export (bool->integer
             integer->bool
             define-foreign
-            define-foreign-record-type
-            foreign-record-pointer))
+            define-foreign-record-type))
 
 (define (bool->integer var)
   (if var 1 0))
@@ -48,33 +46,6 @@
     (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)
@@ -108,44 +79,57 @@
                   (iota (length field-specs))))
 
     (syntax-case x ()
-      ((_ name (make-name make-arg ...) predicate? field-spec ...)
+      ((_ name (make-name make-arg ...) predicate? unwrap-record field-spec ...)
        (with-syntax (((type-id ...) (field-types #'(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-wrapped-pointer-type name
+               predicate?
+               wrap-record unwrap-record
+               (lambda (record port)
+                 (format port "#<~a" 'name)
+                 (let ((values (parse-c-struct (unwrap-record record) (list type-id ...))))
+                   (for-each (lambda (field value)
+                               (format port " ~a: ~a" field value))
+                             '(field-name ...)
+                             values))
+                 (format port ">")))
 
              (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)))))
+               (wrap-record (make-c-struct (list type-id ...) (list make-arg ...))))
 
              (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)))
+               (let ((values (parse-c-struct (unwrap-record record) (list type-id ...))))
                  (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))
+               (let* ((types (list type-id ...))
+                      (type (list-ref types setter-id))
+                      (len (sizeof type))
+                      (offset (if (> setter-id 0)
+                                  (sizeof (list-head types setter-id))
+                                  0))
+                      (bv (pointer->bytevector (unwrap-record record) len offset 'u32)))
+                 (bytevector-set! bv new-value type)
                  new-value))
              ...))))))
+
+(define (bytevector-set! bv value type)
+  (let ((procedure
+         (cond
+           ((= type int8) bytevector-s8-set!)
+           ((= type int16) bytevector-s16-native-set!)
+           ((= type int32) bytevector-s32-native-set!)
+           ((= type int64) bytevector-s64-native-set!)
+           ((= type uint8) bytevector-u8-set!)
+           ((= type uint16) bytevector-u16-native-set!)
+           ((= type uint32) bytevector-u32-native-set!)
+           ((= type uint64) bytevector-u64-native-set!)
+           ((= type float) bytevector-ieee-single-native-set!)
+           ((= type double) bytevector-ieee-double-native-set!)
+           (else #f))))
+    (if procedure
+        (apply procedure bv 0 value '()))))