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 foreign)
22 #:use-module (system foreign)
23 #:use-module (srfi srfi-1)
24 #:use-module (srfi srfi-9)
25 #:use-module (srfi srfi-9 gnu)
26 #:use-module (rnrs bytevectors)
27 #:export (define-foreign
28 define-foreign-record-type
29 foreign-record->pointer
32 get-bit-field-group-type
33 make-c-bit-field-group
34 parse-c-bit-field-group
40 ;; Based on guile-sdl2 function, thanks a lot
42 (let ((cirr (dynamic-link "libCIrrlicht")))
43 (lambda (return-type function-name arg-types)
44 (pointer->procedure return-type
45 (dynamic-func function-name cirr)
48 (define-syntax-rule (define-foreign name return-type func-name arg-types)
50 (irrlicht-func return-type func-name arg-types)))
53 ;; foreign record type
54 (define-record-type standard-foreign-record-type
55 (make-foreign-record-type name types fields)
57 (name foreign-record-type-name)
58 (types foreign-record-type-types)
59 (fields foreign-record-type-fields))
61 (define (foreign-record-type-basic-types record-type)
63 (if (foreign-record-type? type)
64 (foreign-record-type-basic-types type)
66 (foreign-record-type-types record-type)))
70 (define-record-type foreign-record
71 (make-foreign-record type pointer)
73 (type foreign-record-type)
74 (pointer foreign-record-pointer))
76 (set-record-type-printer! foreign-record
78 (let* ((record-type (foreign-record-type record))
79 (name (foreign-record-type-name record-type))
80 (pointer (foreign-record-pointer record))
81 (types (foreign-record-type-types record-type))
82 (fields (foreign-record-type-fields record-type))
83 (values (parse-c-struct pointer types)))
84 (format port "#<~a" name)
85 (for-each (lambda (field value)
86 (format port " ~a: ~a" field value))
91 (define (foreign-record->pointer record)
92 (foreign-record-pointer record))
95 ;; define-foreign-record-type
96 (define-syntax define-foreign-record-type
98 (define (field-names field-specs)
99 (map (lambda (field-spec)
100 (syntax-case field-spec ()
101 ((name type getter) #'name)
102 ((name type getter setter) #'name)))
105 (define (field-types field-specs)
106 (map (lambda (field-spec)
107 (syntax-case field-spec ()
108 ((name type getter) #'type)
109 ((name type getter setter) #'type)))
112 (define (field-getters field-specs)
113 (map (lambda (field-spec field-id)
114 (syntax-case field-spec ()
115 ((name type getter) (list #'getter field-id))
116 ((name type getter setter) (list #'getter field-id))))
118 (iota (length field-specs))))
120 (define (field-setters field-specs)
121 (filter-map (lambda (field-spec field-id)
122 (syntax-case field-spec ()
123 ((name type getter) #f)
124 ((name type getter setter) (list #'setter field-id))))
126 (iota (length field-specs))))
129 ((_ name (make-name make-arg ...) predicate? field-spec ...)
130 (with-syntax (((type-id ...) (field-types #'(field-spec ...)))
131 ((field-name ...) (field-names #'(field-spec ...)))
132 (((getter getter-id) ...) (field-getters #'(field-spec ...)))
133 (((setter setter-id) ...) (field-setters #'(field-spec ...))))
136 (make-foreign-record-type 'name (list type-id ...) (list 'field-name ...)))
138 (define (make-name make-arg ...)
139 (let ((pointer (make-c-struct (list type-id ...) (list make-arg ...))))
140 (make-foreign-record name pointer)))
142 (define (predicate? record)
143 (and (foreign-record? record)
144 (equal? (foreign-record-type-name (foreign-record-type record)) 'name)))
146 (define (getter record)
147 (let ((values (parse-c-struct (foreign-record-pointer record) (list type-id ...))))
148 (list-ref values getter-id)))
151 (define (setter record new-value)
152 (let* ((types (list type-id ...))
153 (type (list-ref types setter-id))
155 (offset (if (> setter-id 0)
156 (sizeof (list-head types setter-id))
158 (bv (pointer->bytevector (foreign-record-pointer record) len offset 'u32)))
159 (bytevector-set! bv new-value type)
163 (define (bytevector-set! bv value type)
166 ((= type int8) bytevector-s8-set!)
167 ((= type int16) bytevector-s16-native-set!)
168 ((= type int32) bytevector-s32-native-set!)
169 ((= type int64) bytevector-s64-native-set!)
170 ((= type uint8) bytevector-u8-set!)
171 ((= type uint16) bytevector-u16-native-set!)
172 ((= type uint32) bytevector-u32-native-set!)
173 ((= type uint64) bytevector-u64-native-set!)
174 ((= type float) bytevector-ieee-single-native-set!)
175 ((= type double) bytevector-ieee-double-native-set!)
178 (apply procedure bv 0 value '()))))
182 (define-record-type bit-field-record
183 (bit-field type bits)
185 (type bit-field-type)
186 (bits bit-field-bits))
188 (define-record-type bit-field-group-subtype-record
189 (make-bit-field-group-subtype type arity maker parser)
190 bit-field-group-subtype?
191 (type bit-field-group-subtype-type)
192 (arity bit-field-group-subtype-arity)
193 (maker bit-field-group-subtype-maker)
194 (parser bit-field-group-subtype-parser))
196 (define-record-type bit-field-group-record
197 (make-bit-field-group subtypes)
199 (subtypes bit-field-group-subtypes))
201 (define (build-bit-field-group-subtype-maker bit-fields)
202 "Return a maker procedure for the bit field group"
204 (let loop ((fields bit-fields)
208 (cond ((null? fields)
213 (cons (ash (car vals) bits) res)
214 (+ bits (bit-field-bits (car fields)))))))))
216 (define (build-bit-field-group-subtype-parser bit-fields)
218 (let loop ((fields bit-fields)
221 (cond ((null? fields)
224 (let ((n-bits (+ bits (bit-field-bits (car fields)))))
226 (append res (list (bit-extract value bits n-bits)))
229 (define (validate-bit-field-group bit-fields)
230 "Return a list with the calculated real types of the bit field group or error if overflow"
231 (let loop ((fields bit-fields)
235 (subtype-fields '()))
236 (cond ((null? fields)
237 (if (> current-type 0)
238 ;; Append last type processed to the result
240 (list (make-bit-field-group-subtype
242 (length subtype-fields)
243 (build-bit-field-group-subtype-maker subtype-fields)
244 (build-bit-field-group-subtype-parser subtype-fields))))
245 ;; We already have the result
248 (let* ((field (car fields))
249 (type (max (bit-field-type field) current-type))
250 (bits (+ (bit-field-bits field) n-bits)))
251 (cond ((> bits (* (sizeof type) 8))
254 ;; Make a new subtype and continue
257 (list (make-bit-field-group-subtype
259 (length subtype-fields)
260 (build-bit-field-group-subtype-maker subtype-fields)
261 (build-bit-field-group-subtype-parser subtype-fields))))
263 ;; Bits exceed type capacity
264 (error "Bit field group overflow")))
266 (loop (cdr fields) type bits subtypes
267 (append subtype-fields (list field))))))))))
269 (define-syntax-rule (bit-field-group (type bits) ...)
270 (let* ((bit-fields (list (bit-field type bits) ...))
271 (subtypes (validate-bit-field-group bit-fields)))
272 (make-bit-field-group subtypes)))
274 (define (get-bit-field-group-type group)
275 (map (lambda (subtype)
276 (bit-field-group-subtype-type subtype))
277 (bit-field-group-subtypes group)))
279 (define (make-c-bit-field-group group values)
280 (let make-c ((subtypes (bit-field-group-subtypes group))
282 (cond ((null? subtypes)
285 (let* ((subtype (car subtypes))
286 (arity (bit-field-group-subtype-arity subtype))
287 (maker (bit-field-group-subtype-maker subtype)))
288 (cons (maker (list-head vals arity))
289 (make-c (cdr subtypes) (list-tail vals arity))))))))
291 (define (parse-c-bit-field-group values group)
293 (map (lambda (subtype value)
294 ((bit-field-group-subtype-parser subtype) value))
295 (bit-field-group-subtypes group)
298 (define (convert-struct types)
299 "Convert a struct type with bit fields in an ordinary struct type"
303 (let ((type (car types)))
305 (cons (convert-struct type)
306 (convert-struct (cdr types))))
307 ((bit-field-group? type)
308 (append (get-bit-field-group-type type)
309 (convert-struct (cdr types))))
312 (convert-struct (cdr types)))))))))
314 (define (convert-struct-values types vals)
315 "Convert struct values with bit fields in an ordinary struct"
319 (let ((type (car types))
322 (cons (convert-struct-values type val)
323 (convert-struct-values (cdr types) (cdr vals))))
324 ((bit-field-group? type)
325 (append (make-c-bit-field-group type val)
326 (convert-struct-values (cdr types) (cdr vals))))
329 (convert-struct-values (cdr types) (cdr vals)))))))))
331 (define (parse-struct-values vals types)
332 "Parse struct values with bit fields from an ordinary struct"
336 (let ((type (car types))
339 (cons (parse-struct-values val type)
340 (parse-struct-values (cdr vals) (cdr types))))
341 ((bit-field-group? type)
342 (let ((arity (length (bit-field-group-subtypes type))))
343 (cons (parse-c-bit-field-group (list-head vals arity) type)
344 (parse-struct-values (list-tail vals arity) (cdr types)))))
347 (parse-struct-values (cdr vals) (cdr types)))))))))
349 (define (sizeof+ type)
351 (sizeof (convert-struct type))
354 (define (make-c-struct+ types vals)
355 (make-c-struct (convert-struct types)
356 (convert-struct-values types vals)))
358 (define (parse-c-struct+ foreign types)
360 (parse-c-struct foreign (convert-struct types))