From 2a0373b3eda4407e2e41a4e8fc3a7333bb789a89 Mon Sep 17 00:00:00 2001
From: Javier Sancho <jsf@jsancho.org>
Date: Thu, 9 Jan 2020 10:24:19 +0100
Subject: [PATCH] Bindings refactor

---
 examples/01.HelloWorld.scm  |   4 +-
 examples/02.Quake3Map.scm   |   2 +-
 irrlicht.scm                |   5 +-
 irrlicht/aabbox3d.scm       |  63 -------------
 irrlicht/bindings.scm       |   2 +-
 irrlicht/bindings/core.scm  |  36 ++++++--
 irrlicht/bindings/gui.scm   |   2 +-
 irrlicht/bindings/io.scm    |   2 +-
 irrlicht/bindings/scene.scm |   4 +-
 irrlicht/bindings/video.scm |   5 +-
 irrlicht/device.scm         |   6 +-
 irrlicht/dimension2d.scm    |  35 --------
 irrlicht/gui.scm            |   2 +-
 irrlicht/rect.scm           |  39 ---------
 irrlicht/scene.scm          |  49 +++++++----
 irrlicht/util.scm           | 112 +-----------------------
 irrlicht/util/foreign.scm   | 170 ++++++++++++++++++++++++++++++++++++
 irrlicht/video.scm          |   4 +-
 tests/foreign-record.log    |  50 +++++++++++
 tests/foreign-record.scm    |  20 ++++-
 20 files changed, 321 insertions(+), 291 deletions(-)
 delete mode 100644 irrlicht/aabbox3d.scm
 delete mode 100644 irrlicht/dimension2d.scm
 delete mode 100644 irrlicht/rect.scm
 create mode 100644 irrlicht/util/foreign.scm
 create mode 100644 tests/foreign-record.log

diff --git a/examples/01.HelloWorld.scm b/examples/01.HelloWorld.scm
index 5a34116..3f128cb 100644
--- a/examples/01.HelloWorld.scm
+++ b/examples/01.HelloWorld.scm
@@ -28,7 +28,7 @@
 (define device
   (create-device
    #:device-type 'software
-   #:window-size (make-dimension2d 640 480)))
+   #:window-size '(640 480)))
 (when (not device)
   (exit #f))
 
@@ -42,7 +42,7 @@
 (add-static-text!
  gui-env
  "Hello World! This is the Irrlicht Software renderer!"
- (make-rect 10 10 260 22)
+ '(10 10 260 22)
  #:border #t)
 
 ;; load a Quake2 model
diff --git a/examples/02.Quake3Map.scm b/examples/02.Quake3Map.scm
index 5f26f2a..45249ac 100644
--- a/examples/02.Quake3Map.scm
+++ b/examples/02.Quake3Map.scm
@@ -52,7 +52,7 @@
 (define device
   (create-device
    #:device-type driver
-   #:window-size (make-dimension2d 640 480)))
+   #:window-size '(640 480)))
 (when (not device)
   (exit #f))
 
diff --git a/irrlicht.scm b/irrlicht.scm
index e7dcb4b..f3474c6 100644
--- a/irrlicht.scm
+++ b/irrlicht.scm
@@ -23,12 +23,9 @@
 (eval-when (eval load compile)
   ;; load public symbols into current module
   (let ((public-modules
-         '((irrlicht aabbox3d)
-           (irrlicht device)
-           (irrlicht dimension2d)
+         '((irrlicht device)
            (irrlicht gui)
            (irrlicht io)
-           (irrlicht rect)
            (irrlicht scene)
            (irrlicht video)))
         (current-interface
diff --git a/irrlicht/aabbox3d.scm b/irrlicht/aabbox3d.scm
deleted file mode 100644
index 55d71a4..0000000
--- a/irrlicht/aabbox3d.scm
+++ /dev/null
@@ -1,63 +0,0 @@
-;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
-;;; Copyright (C) 2019 Javier Sancho <jsf@jsancho.org>
-;;;
-;;; This file is part of guile-irrlicht.
-;;;
-;;; Guile-irrlicht is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU Lesser General Public License as
-;;; published by the Free Software Foundation; either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; Guile-irrlicht is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Lesser General Public
-;;; License along with guile-irrlicht.  If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-
-(define-module (irrlicht aabbox3d)
-  #:use-module (srfi srfi-9)
-  #:use-module (srfi srfi-9 gnu)
-  #:use-module (system foreign)
-  #:use-module ((irrlicht bindings core) #:prefix ffi-core:)
-  #:export (make-aabbox3d
-            aabbox3d-min-edge
-            aabbox3d-max-edge
-            aabbox3d-reset!
-            aabbox3d-add-internal-point!))
-
-(define-record-type <aabbox3d>
-  (make-raw-aabbox3d c-pointer)
-  aabbox3d?
-  (c-pointer aabbox3d-c-pointer))
-
-(define* (make-aabbox3d #:optional (min-edge '(0 0 0)) (max-edge min-edge))
-  (make-raw-aabbox3d
-   (make-c-struct ffi-core:aabbox3d_f32 (append min-edge max-edge))))
-
-(define (aabbox3d-min-edge box)
-  (let ((data (parse-c-struct (aabbox3d-c-pointer box) ffi-core:aabbox3d_f32)))
-    (list-head data 3)))
-
-(define (aabbox3d-max-edge box)
-  (let ((data (parse-c-struct (aabbox3d-c-pointer box) ffi-core:aabbox3d_f32)))
-    (list-tail data 3)))
-
-(define (aabbox3d-reset! box point)
-  (ffi-core:aabbox3d-reset
-   (aabbox3d-c-pointer box)
-   (make-c-struct ffi-core:vector3df point)))
-
-(define (aabbox3d-add-internal-point! box point)
-  (ffi-core:aabbox3d-add-internal-point
-   (aabbox3d-c-pointer box)
-   (make-c-struct ffi-core:vector3df point)))
-
-(set-record-type-printer! <aabbox3d>
-  (lambda (record port)
-    (let ((min (aabbox3d-min-edge record))
-          (max (aabbox3d-max-edge record)))
-      (format port "#<aabbox3d min: ~a max: ~a>" min max))))
diff --git a/irrlicht/bindings.scm b/irrlicht/bindings.scm
index a7031a9..2592e59 100644
--- a/irrlicht/bindings.scm
+++ b/irrlicht/bindings.scm
@@ -20,7 +20,7 @@
 
 (define-module (irrlicht bindings)
   #:use-module (system foreign)
-  #:use-module (irrlicht util))
+  #:use-module (irrlicht util foreign))
 
 (define-foreign create-device
   '* "irr_createDevice" (list int '* uint32 int int int))
diff --git a/irrlicht/bindings/core.scm b/irrlicht/bindings/core.scm
index 20d8e84..e0a13af 100644
--- a/irrlicht/bindings/core.scm
+++ b/irrlicht/bindings/core.scm
@@ -20,22 +20,42 @@
 
 (define-module (irrlicht bindings core)
   #:use-module (system foreign)
-  #:use-module (irrlicht util))
+  #:use-module (irrlicht util foreign))
+
+;; dimension2d struct
+(define-public dimension2d
+  (list uint32 uint32))
+
+(define-public (dimension2d->pointer data)
+  (make-c-struct dimension2d data))
+
+;; rect struct
+(define-public rect
+  (list int32 int32 int32 int32))
+
+(define-public (rect->pointer data)
+  (make-c-struct rect data))
 
 ;; vector2df struct
 (define-public vector2df
-  (list float float float))
+  (list float float))
+
+(define-public (vector2df->pointer data)
+  (make-c-struct vector2df data))
 
 ;; vector3df struct
 (define-public vector3df
   (list float float float))
 
-;; aabbox3d f32 struct and functions
-(define-public aabbox3d_f32
-  (append
-   vector3df  ; min-edge
-   vector3df  ; max-edge
-   ))
+(define-public (vector3df->pointer data)
+  (make-c-struct vector3df data))
+
+;; aabbox3df struct
+(define-public aabbox3df
+  (list vector3df vector3df))
+
+(define-public (aabbox3df->pointer data)
+  (make-c-struct aabbox3df data))
 
 (define-foreign aabbox3d-add-internal-point
   void "irr_core_aabbox3d_addInternalPoint" (list '* '*))
diff --git a/irrlicht/bindings/gui.scm b/irrlicht/bindings/gui.scm
index ad2a8c8..9aac7ca 100644
--- a/irrlicht/bindings/gui.scm
+++ b/irrlicht/bindings/gui.scm
@@ -20,7 +20,7 @@
 
 (define-module (irrlicht bindings gui)
   #:use-module (system foreign)
-  #:use-module (irrlicht util))
+  #:use-module (irrlicht util foreign))
 
 (define-foreign add-static-text
   '* "irr_gui_addStaticText" (list '* '* '* int int '* int int))
diff --git a/irrlicht/bindings/io.scm b/irrlicht/bindings/io.scm
index 3373a7b..aafbed6 100644
--- a/irrlicht/bindings/io.scm
+++ b/irrlicht/bindings/io.scm
@@ -21,7 +21,7 @@
 (define-module (irrlicht bindings io)
   #:use-module (system foreign)
   #:use-module (rnrs arithmetic bitwise)
-  #:use-module (irrlicht util))
+  #:use-module (irrlicht util foreign))
 
 (define (make-cirr-id c0 c1 c2 c3)
   (define (char->numeric c)
diff --git a/irrlicht/bindings/scene.scm b/irrlicht/bindings/scene.scm
index 6a54f18..74b1535 100644
--- a/irrlicht/bindings/scene.scm
+++ b/irrlicht/bindings/scene.scm
@@ -20,7 +20,7 @@
 
 (define-module (irrlicht bindings scene)
   #:use-module (system foreign)
-  #:use-module (irrlicht util))
+  #:use-module (irrlicht util foreign))
 
 ;;  irr_scene_EMD2_ANIMATION_TYPE enum
 (define-public EMAT_STAND                 0)
@@ -57,7 +57,7 @@
   '* "irr_scene_addCameraSceneNodeFPS" (list '* '* float float int '* int int float int int))
 
 (define-foreign add-custom-scene-node
-  '* "irr_scene_addCustomSceneNode" (list '* '* int '*))
+  '* "irr_scene_addCustomSceneNode" (list '* '* int '* '* '* '* '* '* '*))
 
 (define-foreign add-octree-scene-node
   '* "irr_scene_addOctreeSceneNode" (list '* '* '* int int int))
diff --git a/irrlicht/bindings/video.scm b/irrlicht/bindings/video.scm
index ec117b3..2e60ff3 100644
--- a/irrlicht/bindings/video.scm
+++ b/irrlicht/bindings/video.scm
@@ -20,7 +20,7 @@
 
 (define-module (irrlicht bindings video)
   #:use-module (system foreign)
-  #:use-module (irrlicht util))
+  #:use-module (irrlicht util foreign))
 
 ;; E_DRIVER_TYPE enum
 (define-public EDT_NULL            0)
@@ -58,6 +58,9 @@
 (define-public scolor
   (list uint8 uint8 uint8 uint8))
 
+(define-public (scolor->pointer data)
+  (make-c-struct scolor (reverse data)))
+
 ;; Driver functions
 (define-foreign begin-scene
   int "irr_video_beginScene" (list '* int int '* '* '*))
diff --git a/irrlicht/device.scm b/irrlicht/device.scm
index c773dbc..8fcc652 100644
--- a/irrlicht/device.scm
+++ b/irrlicht/device.scm
@@ -22,8 +22,8 @@
   #:use-module (ice-9 match)
   #:use-module (system foreign)
   #:use-module ((irrlicht bindings) #:prefix ffi:)
+  #:use-module ((irrlicht bindings core) #:prefix ffi-core:)
   #:use-module ((irrlicht bindings video) #:prefix ffi-video:)
-  #:use-module (irrlicht dimension2d)
   #:use-module (irrlicht util)
   #:export (create-device
             get-cursor-control
@@ -38,7 +38,7 @@
 
 (define* (create-device #:key
                         (device-type 'software)
-                        (window-size (make-dimension2d 640 480))
+                        (window-size '(640 480))
                         (bits 16)
                         (fullscreen #f)
                         (stencilbuffer #f)
@@ -52,7 +52,7 @@
                        ('opengl ffi-video:EDT_OPENGL)
                        ('count ffi-video:EDT_COUNT))))
     (let ((device (ffi:create-device driver
-                                     (foreign-record->pointer window-size)
+                                     (ffi-core:dimension2d->pointer window-size)
                                      bits
                                      (bool->integer fullscreen)
                                      (bool->integer stencilbuffer)
diff --git a/irrlicht/dimension2d.scm b/irrlicht/dimension2d.scm
deleted file mode 100644
index 7eb8cfd..0000000
--- a/irrlicht/dimension2d.scm
+++ /dev/null
@@ -1,35 +0,0 @@
-;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
-;;; Copyright (C) 2019 Javier Sancho <jsf@jsancho.org>
-;;;
-;;; This file is part of guile-irrlicht.
-;;;
-;;; Guile-irrlicht is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU Lesser General Public License as
-;;; published by the Free Software Foundation; either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; Guile-irrlicht is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Lesser General Public
-;;; License along with guile-irrlicht.  If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-
-(define-module (irrlicht dimension2d)
-  #:use-module (system foreign)
-  #:use-module (irrlicht util)
-  #:export (dimension2d
-            make-dimension2d
-            dimension2d?
-            dimension2d-width
-            dimension2d-height))
-
-;; dimension2d struct
-(define-foreign-record-type dimension2d
-  (make-dimension2d width height)
-  dimension2d?
-  (width uint32 dimension2d-width)
-  (height uint32 dimension2d-height))
diff --git a/irrlicht/gui.scm b/irrlicht/gui.scm
index bd5eede..8a4c97e 100644
--- a/irrlicht/gui.scm
+++ b/irrlicht/gui.scm
@@ -37,7 +37,7 @@
                            (fill-background #f))
   (ffi-gui:add-static-text gui-env
                            (string->pointer text)
-                           (foreign-record->pointer rectangle)
+                           (ffi-core:rect->pointer rectangle)
                            (bool->integer border)
                            (bool->integer word-wrap)
                            parent
diff --git a/irrlicht/rect.scm b/irrlicht/rect.scm
deleted file mode 100644
index b73f32d..0000000
--- a/irrlicht/rect.scm
+++ /dev/null
@@ -1,39 +0,0 @@
-;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
-;;; Copyright (C) 2019 Javier Sancho <jsf@jsancho.org>
-;;;
-;;; This file is part of guile-irrlicht.
-;;;
-;;; Guile-irrlicht is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU Lesser General Public License as
-;;; published by the Free Software Foundation; either version 3 of the
-;;; License, or (at your option) any later version.
-;;;
-;;; Guile-irrlicht is distributed in the hope that it will be useful, but
-;;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;;; General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU Lesser General Public
-;;; License along with guile-irrlicht.  If not, see
-;;; <http://www.gnu.org/licenses/>.
-
-
-(define-module (irrlicht rect)
-  #:use-module (system foreign)
-  #:use-module (irrlicht util)
-  #:export (rect
-            make-rect
-            rect?
-            rect-x
-            rect-y
-            rect-x2
-            rect-y2))
-
-;; rect struct
-(define-foreign-record-type rect
-  (make-rect x y x2 y2)
-  rect?
-  (x int32 rect-x)
-  (y int32 rect-y)
-  (x2 int32 rect-x2)
-  (y2 int32 rect-y2))
diff --git a/irrlicht/scene.scm b/irrlicht/scene.scm
index 2f2aa50..7e9b8d2 100644
--- a/irrlicht/scene.scm
+++ b/irrlicht/scene.scm
@@ -51,9 +51,9 @@
                mesh
                parent
                id
-               (make-c-struct ffi-core:vector3df position)
-               (make-c-struct ffi-core:vector3df rotation)
-               (make-c-struct ffi-core:vector3df scale)
+               (ffi-core:vector3df->pointer position)
+               (ffi-core:vector3df->pointer rotation)
+               (ffi-core:vector3df->pointer scale)
                (bool->integer also-add-if-mesh-pointer-zero))))
     (if (null-pointer? node) #f node)))
 
@@ -67,8 +67,8 @@
   (let ((camera (ffi-scene:add-camera-scene-node
                  scene-manager
                  parent
-                 (make-c-struct ffi-core:vector3df position)
-                 (make-c-struct ffi-core:vector3df lookat)
+                 (ffi-core:vector3df->pointer position)
+                 (ffi-core:vector3df->pointer lookat)
                  id
                  (bool->integer make-active))))
     (if (null-pointer? camera) #f camera)))
@@ -98,15 +98,34 @@
    (bool->integer invert-mouse)
    (bool->integer make-active)))
 
-(define (add-custom-scene-node! parent
-                                scene-manager
-                                id
-                                custom-render)
-  (ffi-scene:add-custom-scene-node
-   parent
-   scene-manager
-   id
-   (procedure->pointer void custom-render '())))
+(define* (add-custom-scene-node! scene-manager
+                                 render
+                                 get-bounding-box
+                                 get-material-count
+                                 get-material
+                                 #:key
+                                 (parent %null-pointer)
+                                 (id -1)
+                                 (position '(0 0 0))
+                                 (rotation '(0 0 0))
+                                 (scale '(1 1 1)))
+  (let ((c-get-bounding-box
+         (lambda ()
+           (ffi-core:aabbox3df->pointer (get-bounding-box))))
+        (c-get-material
+         (lambda (i)
+           (ffi-core:material->pointer (get-material i)))))
+    (ffi-scene:add-custom-scene-node
+     scene-manager
+     parent
+     id
+     (ffi-core:vector3df->pointer position)
+     (ffi-core:vector3df->pointer rotation)
+     (ffi-core:vector3df->pointer scale)
+     (procedure->pointer void render '())
+     (procedure->pointer '* c-get-bounding-box '())
+     (procedure->pointer uint32 get-material-count '())
+     (procedure->pointer '* c-get-material (list uint32)))))
 
 (define* (add-octree-scene-node scene-manager mesh
                                 #:key
@@ -195,4 +214,4 @@
 (define (set-position! node newpos)
   (ffi-scene:set-position
    node
-   (make-c-struct ffi-core:vector3df newpos)))
+   (ffi-core:vector3df->pointer newpos)))
diff --git a/irrlicht/util.scm b/irrlicht/util.scm
index efa5ba7..8c5b9e4 100644
--- a/irrlicht/util.scm
+++ b/irrlicht/util.scm
@@ -19,121 +19,11 @@
 
 
 (define-module (irrlicht util)
-  #:use-module (system foreign)
-  #:use-module (srfi srfi-1)
-  #:use-module (rnrs bytevectors)
   #:export (bool->integer
-            integer->bool
-            define-foreign
-            define-foreign-record-type
-            foreign-record->pointer))
+            integer->bool))
 
 (define (bool->integer var)
   (if var 1 0))
 
 (define (integer->bool var)
   (if (= var 0) #f #t))
-
-;; Based on guile-sdl2 function, thanks a lot
-(define irrlicht-func
-  (let ((cirr (dynamic-link "libCIrrlicht")))
-    (lambda (return-type function-name arg-types)
-      (pointer->procedure return-type
-                          (dynamic-func function-name cirr)
-                          arg-types))))
-
-(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-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))
-
-    (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 ...)))
-                     (((getter getter-id) ...) (field-getters #'(field-spec ...)))
-                     (((setter setter-id) ...) (field-setters #'(field-spec ...))))
-         #'(begin
-             (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 ...)
-               (wrap-record (make-c-struct (list type-id ...) (list make-arg ...))))
-
-             (define (getter record)
-               (let ((values (parse-c-struct (unwrap-record record) (list type-id ...))))
-                 (list-ref values getter-id)))
-             ...
-
-             (define (setter record new-value)
-               (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 '()))))
-
-(define (foreign-record->pointer record)
-  (struct-ref record 0))
diff --git a/irrlicht/util/foreign.scm b/irrlicht/util/foreign.scm
new file mode 100644
index 0000000..8c9a9ad
--- /dev/null
+++ b/irrlicht/util/foreign.scm
@@ -0,0 +1,170 @@
+;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
+;;; Copyright (C) 2019 Javier Sancho <jsf@jsancho.org>
+;;;
+;;; This file is part of guile-irrlicht.
+;;;
+;;; Guile-irrlicht is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation; either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; Guile-irrlicht is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with guile-irrlicht.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+
+(define-module (irrlicht util foreign)
+  #: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 (define-foreign
+            define-foreign-record-type
+            foreign-record->pointer))
+
+
+;; Based on guile-sdl2 function, thanks a lot
+(define irrlicht-func
+  (let ((cirr (dynamic-link "libCIrrlicht")))
+    (lambda (return-type function-name arg-types)
+      (pointer->procedure return-type
+                          (dynamic-func function-name cirr)
+                          arg-types))))
+
+(define-syntax-rule (define-foreign name return-type func-name arg-types)
+  (define-public name
+    (irrlicht-func return-type func-name arg-types)))
+
+
+;; foreign 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 (foreign-record-type-basic-types record-type)
+  (map (lambda (type)
+         (if (foreign-record-type? type)
+             (foreign-record-type-basic-types type)
+             type))
+       (foreign-record-type-types record-type)))
+
+
+;; foreign record
+(define-record-type foreign-record
+  (make-foreign-record type pointer)
+  foreign-record?
+  (type foreign-record-type)
+  (pointer foreign-record-pointer))
+
+(set-record-type-printer! foreign-record
+  (lambda (record port)
+    (let* ((record-type (foreign-record-type record))
+           (name (foreign-record-type-name record-type))
+           (pointer (foreign-record-pointer record))
+           (types (foreign-record-type-types record-type))
+           (fields (foreign-record-type-fields record-type))
+           (values (parse-c-struct pointer types)))
+      (format port "#<~a" name)
+      (for-each (lambda (field value)
+                  (format port " ~a: ~a" field value))
+                fields
+                values)
+      (format port ">"))))
+
+(define (foreign-record->pointer record)
+  (foreign-record-pointer record))
+
+
+;; define-foreign-record-type
+(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))
+
+    (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 ...)))
+                     (((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 ((pointer (make-c-struct (list type-id ...) (list make-arg ...))))
+                 (make-foreign-record name pointer)))
+
+             (define (predicate? record)
+               (and (foreign-record? record)
+                    (equal? (foreign-record-type-name (foreign-record-type record)) 'name)))
+
+             (define (getter record)
+               (let ((values (parse-c-struct (foreign-record-pointer record) (list type-id ...))))
+                 (list-ref values getter-id)))
+             ...
+
+             (define (setter record new-value)
+               (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 (foreign-record-pointer 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 '()))))
diff --git a/irrlicht/video.scm b/irrlicht/video.scm
index 7fc99fa..ed13371 100644
--- a/irrlicht/video.scm
+++ b/irrlicht/video.scm
@@ -39,11 +39,11 @@
   (ffi-video:begin-scene driver
                          (bool->integer back-buffer)
                          (bool->integer z-buffer)
-                         (make-c-struct ffi-video:scolor (reverse color))
+                         (ffi-video:scolor->pointer color)
                          video-data
                          (if (null? source-rect)
                              %null-pointer
-                             (make-c-struct ffi-core:rect source-rect))))
+                             (ffi-core:rect->pointer source-rect))))
 
 (define (end-scene driver)
   (ffi-video:end-scene driver))
diff --git a/tests/foreign-record.log b/tests/foreign-record.log
new file mode 100644
index 0000000..3bb1448
--- /dev/null
+++ b/tests/foreign-record.log
@@ -0,0 +1,50 @@
+%%%% Starting test foreign-record
+Group begin: foreign-record
+Test begin:
+  source-file: "tests/foreign-record.scm"
+  source-line: 36
+  source-form: (test-assert (dimension2d? dim))
+Test end:
+  result-kind: pass
+  actual-value: #t
+Test begin:
+  source-file: "tests/foreign-record.scm"
+  source-line: 37
+  source-form: (test-equal 10 (dimension2d-width dim))
+Test end:
+  result-kind: pass
+  actual-value: 10
+  expected-value: 10
+Test begin:
+  source-file: "tests/foreign-record.scm"
+  source-line: 38
+  source-form: (test-equal 20 (dimension2d-height dim))
+Test end:
+  result-kind: pass
+  actual-value: 20
+  expected-value: 20
+Test begin:
+  source-file: "tests/foreign-record.scm"
+  source-line: 43
+  source-form: (test-equal 50 (dimension2d-width dim))
+Test end:
+  result-kind: pass
+  actual-value: 50
+  expected-value: 50
+Test begin:
+  source-file: "tests/foreign-record.scm"
+  source-line: 44
+  source-form: (test-equal 100 (dimension2d-height dim))
+Test end:
+  result-kind: pass
+  actual-value: 100
+  expected-value: 100
+Test begin:
+  source-file: "tests/foreign-record.scm"
+  source-line: 47
+  source-form: (test-assert (pointer? (foreign-record->pointer dim)))
+Test end:
+  result-kind: pass
+  actual-value: #t
+Group end: foreign-record
+# of expected passes      6
diff --git a/tests/foreign-record.scm b/tests/foreign-record.scm
index 39b8c44..9bc8dee 100644
--- a/tests/foreign-record.scm
+++ b/tests/foreign-record.scm
@@ -20,7 +20,7 @@
 
 (use-modules (system foreign)
              (srfi srfi-64)
-             (irrlicht util))
+             (irrlicht util foreign))
 
 (test-begin "foreign-record")
 
@@ -33,6 +33,7 @@
 
 ;; Create dimension
 (define dim (make-dimension2d 10 20))
+(test-assert (dimension2d? dim))
 (test-equal 10 (dimension2d-width dim))
 (test-equal 20 (dimension2d-height dim))
 
@@ -45,4 +46,21 @@
 ;; Is a pointer
 (test-assert (pointer? (foreign-record->pointer dim)))
 
+;; Foreign record types as types for other foreign records
+(define-foreign-record-type point
+  (make-point x y)
+  point?
+  (x int64 point-x)
+  (y int64 point-y))
+
+(define-foreign-record-type triangle
+  (make-triangle p1 p2 p3)
+  triangle?
+  (p1 point triangle-p1)
+  (p2 point triangle-p2)
+  (p3 point triangle-p3))
+
+;(define tr (make-triangle (make-point 0 10) (make-point -10 5) (make-point 15 -7)))
+;(test-equal -10 (point-x (triangle-p2 tr)))
+
 (test-end "foreign-record")
-- 
2.39.2