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 (srfi srfi-9)
25 #:use-module (srfi srfi-9 gnu)
26 #:export (bool->integer
29 define-foreign-record-type
30 foreign-record-pointer))
32 (define (bool->integer var)
35 (define (integer->bool var)
38 ;; Based on guile-sdl2 function, thanks a lot
40 (let ((cirr (dynamic-link "libCIrrlicht")))
41 (lambda (return-type function-name arg-types)
42 (pointer->procedure return-type
43 (dynamic-func function-name cirr)
46 (define-syntax-rule (define-foreign name return-type func-name arg-types)
48 (irrlicht-func return-type func-name arg-types)))
50 ;; foreign struct record type
51 (define-record-type standard-foreign-record-type
52 (make-foreign-record-type name types fields)
54 (name foreign-record-type-name)
55 (types foreign-record-type-types)
56 (fields foreign-record-type-fields))
58 (define-record-type foreign-record
59 (make-foreign-record type pointer)
61 (type foreign-record-type)
62 (pointer foreign-record-pointer set-foreign-record-pointer!))
64 (set-record-type-printer! foreign-record
66 (format port "#<~a" (foreign-record-type-name (foreign-record-type record)))
67 (let* ((pointer (foreign-record-pointer record))
68 (record-type (foreign-record-type record))
69 (types (foreign-record-type-types record-type))
70 (fields (foreign-record-type-fields record-type))
71 (values (parse-c-struct pointer types)))
72 (for-each (lambda (field value)
73 (format port " ~a: ~a" field value))
78 (define-syntax define-foreign-record-type
80 (define (field-names field-specs)
81 (map (lambda (field-spec)
82 (syntax-case field-spec ()
83 ((name type getter) #'name)
84 ((name type getter setter) #'name)))
87 (define (field-types field-specs)
88 (map (lambda (field-spec)
89 (syntax-case field-spec ()
90 ((name type getter) #'type)
91 ((name type getter setter) #'type)))
94 (define (field-getters field-specs)
95 (map (lambda (field-spec field-id)
96 (syntax-case field-spec ()
97 ((name type getter) (list #'getter field-id))
98 ((name type getter setter) (list #'getter field-id))))
100 (iota (length field-specs))))
102 (define (field-setters field-specs)
103 (filter-map (lambda (field-spec field-id)
104 (syntax-case field-spec ()
105 ((name type getter) #f)
106 ((name type getter setter) (list #'setter field-id))))
108 (iota (length field-specs))))
111 ((_ name (make-name make-arg ...) predicate? field-spec ...)
112 (with-syntax (((type-id ...) (field-types #'(field-spec ...)))
113 ((field-name ...) (field-names #'(field-spec ...)))
114 (((getter getter-id) ...) (field-getters #'(field-spec ...)))
115 (((setter setter-id) ...) (field-setters #'(field-spec ...))))
118 (make-foreign-record-type
121 (list 'field-name ...)))
123 (define (make-name make-arg ...)
124 (let* ((types (foreign-record-type-types name))
125 (c-struct-pointer (make-c-struct types (list make-arg ...))))
126 (make-foreign-record name c-struct-pointer)))
128 (define (predicate? record)
130 (foreign-record? record)
131 (let* ((record-type (foreign-record-type record))
132 (type-name (foreign-record-type-name record-type)))
133 (equal? type-name (foreign-record-type-name name)))))
135 (define (getter record)
136 (let* ((pointer (foreign-record-pointer record))
137 (record-type (foreign-record-type record))
138 (types (foreign-record-type-types record-type))
139 (values (parse-c-struct pointer types)))
140 (list-ref values getter-id)))
143 (define (setter record new-value)
144 (let* ((pointer (foreign-record-pointer record))
145 (record-type (foreign-record-type record))
146 (types (foreign-record-type-types record-type))
147 (values (parse-c-struct pointer types)))
148 (list-set! values setter-id new-value)
149 (set-foreign-record-pointer! record (make-c-struct types values))