From: Javier Sancho Date: Thu, 9 Jan 2020 09:24:19 +0000 (+0100) Subject: Bindings refactor X-Git-Url: https://git.jsancho.org/?a=commitdiff_plain;h=2a0373b3eda4407e2e41a4e8fc3a7333bb789a89;p=guile-irrlicht.git Bindings refactor --- 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 -;;; -;;; 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 -;;; . - - -(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 - (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! - (lambda (record port) - (let ((min (aabbox3d-min-edge record)) - (max (aabbox3d-max-edge record))) - (format port "#" 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 -;;; -;;; 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 -;;; . - - -(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 -;;; -;;; 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 -;;; . - - -(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 +;;; +;;; 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 +;;; . + + +(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")