1 ;;; guile-irrlicht --- FFI bindings for Irrlicht Engine
2 ;;; Copyright (C) 2019 Javier Sancho <jsf@jsancho.org>
4 ;;; This file is part of guile-irrlicht.
6 ;;; Guile-irrlicht is free software; you can redistribute it and/or modify
7 ;;; it under the terms of the GNU Lesser General Public License as
8 ;;; published by the Free Software Foundation; either version 3 of the
9 ;;; License, or (at your option) any later version.
11 ;;; Guile-irrlicht is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;; General Public License for more details.
16 ;;; You should have received a copy of the GNU Lesser General Public
17 ;;; License along with guile-irrlicht. If not, see
18 ;;; <http://www.gnu.org/licenses/>.
21 (define-module (irrlicht util)
22 #:use-module (system foreign)
23 #:use-module (srfi srfi-1)
24 #:use-module (rnrs bytevectors)
25 #:export (bool->integer
28 define-foreign-record-type))
30 (define (bool->integer var)
33 (define (integer->bool var)
36 ;; Based on guile-sdl2 function, thanks a lot
38 (let ((cirr (dynamic-link "libCIrrlicht")))
39 (lambda (return-type function-name arg-types)
40 (pointer->procedure return-type
41 (dynamic-func function-name cirr)
44 (define-syntax-rule (define-foreign name return-type func-name arg-types)
46 (irrlicht-func return-type func-name arg-types)))
48 ;; foreign struct record type
49 (define-syntax define-foreign-record-type
51 (define (field-names field-specs)
52 (map (lambda (field-spec)
53 (syntax-case field-spec ()
54 ((name type getter) #'name)
55 ((name type getter setter) #'name)))
58 (define (field-types field-specs)
59 (map (lambda (field-spec)
60 (syntax-case field-spec ()
61 ((name type getter) #'type)
62 ((name type getter setter) #'type)))
65 (define (field-getters field-specs)
66 (map (lambda (field-spec field-id)
67 (syntax-case field-spec ()
68 ((name type getter) (list #'getter field-id))
69 ((name type getter setter) (list #'getter field-id))))
71 (iota (length field-specs))))
73 (define (field-setters field-specs)
74 (filter-map (lambda (field-spec field-id)
75 (syntax-case field-spec ()
76 ((name type getter) #f)
77 ((name type getter setter) (list #'setter field-id))))
79 (iota (length field-specs))))
82 ((_ name (make-name make-arg ...) predicate? unwrap-record field-spec ...)
83 (with-syntax (((type-id ...) (field-types #'(field-spec ...)))
84 ((field-name ...) (field-names #'(field-spec ...)))
85 (((getter getter-id) ...) (field-getters #'(field-spec ...)))
86 (((setter setter-id) ...) (field-setters #'(field-spec ...))))
88 (define-wrapped-pointer-type name
90 wrap-record unwrap-record
92 (format port "#<~a" 'name)
93 (let ((values (parse-c-struct (unwrap-record record) (list type-id ...))))
94 (for-each (lambda (field value)
95 (format port " ~a: ~a" field value))
100 (define (make-name make-arg ...)
101 (wrap-record (make-c-struct (list type-id ...) (list make-arg ...))))
103 (define (getter record)
104 (let ((values (parse-c-struct (unwrap-record record) (list type-id ...))))
105 (list-ref values getter-id)))
108 (define (setter record new-value)
109 (let* ((types (list type-id ...))
110 (type (list-ref types setter-id))
112 (offset (if (> setter-id 0)
113 (sizeof (list-head types setter-id))
115 (bv (pointer->bytevector (unwrap-record record) len offset 'u32)))
116 (bytevector-set! bv new-value type)
120 (define (bytevector-set! bv value type)
123 ((= type int8) bytevector-s8-set!)
124 ((= type int16) bytevector-s16-native-set!)
125 ((= type int32) bytevector-s32-native-set!)
126 ((= type int64) bytevector-s64-native-set!)
127 ((= type uint8) bytevector-u8-set!)
128 ((= type uint16) bytevector-u16-native-set!)
129 ((= type uint32) bytevector-u32-native-set!)
130 ((= type uint64) bytevector-u64-native-set!)
131 ((= type float) bytevector-ieee-single-native-set!)
132 ((= type double) bytevector-ieee-double-native-set!)
135 (apply procedure bv 0 value '()))))