]> git.jsancho.org Git - guile-assimp.git/blob - src/assimp/low-level.scm
Sources Reorganization
[guile-assimp.git] / src / assimp / low-level.scm
1 ;;; guile-assimp, foreign interface to libassimp
2 ;;; Copyright (C) 2014 by Javier Sancho Fernandez <jsf at jsancho dot org>
3 ;;;
4 ;;; This program is free software: you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published by
6 ;;; the Free Software Foundation, either version 3 of the License, or
7 ;;; (at your option) any later version.
8 ;;;
9 ;;; This program is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12 ;;; GNU General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU General Public License
15 ;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
16
17
18 (define-module (assimp low-level)
19   #:use-module (ice-9 iconv)
20   #:use-module (rnrs bytevectors)
21   #:use-module (system foreign))
22
23
24 ;;; Generic Functions
25
26 (define (mk-string . args)
27   (string-concatenate
28    (map (lambda (a)
29           (if (string? a)
30               a
31               (symbol->string (syntax->datum a))))
32         args)))
33
34 (define (lambda-mk-symbol x)
35   (lambda args
36     (datum->syntax x
37       (string->symbol
38        (apply mk-string args)))))
39
40
41 ;;; Parsers Definition
42
43 (define-syntax define-struct-parser
44   (lambda (x)
45     (syntax-case x ()
46       ((_ name (field type) ...)
47        (with-syntax (((field-name ...) (map car #'((field type) ...)))
48                      ((field-type ...) (map cadr #'((field type) ...))))
49          #'(define* (name pointer-or-data #:key (reverse #f))
50              (cond (reverse
51                     (make-c-struct
52                      (list field-type ...)
53                      pointer-or-data))
54                    (else
55                     (map cons
56                          '(field-name ...)
57                          (parse-c-struct pointer-or-data (list field-type ...)))))))))))
58
59 (export-syntax define-struct-parser)
60
61
62 ;;; Type Generation
63
64 (define-syntax define-conversion-type
65   (lambda (x)
66     (define mk-symbol (lambda-mk-symbol x))
67     (syntax-case x (->)
68       ((_ parser -> name (field-name field-proc) ...)
69        (with-syntax ((type? (mk-symbol #'name "?"))
70                      (wrap-type (mk-symbol "wrap-" #'name))
71                      (unwrap-type (mk-symbol "unwrap-" #'name))
72                      (output-string (mk-string "#<" #'name " ~x>"))
73                      (type-contents (mk-symbol #'name "-contents"))
74                      (type-parse (mk-symbol #'name "-parse"))
75                      ((field-reader ...) (map (lambda (f) (mk-symbol #'name "-" (car f))) #'((field-name field-proc) ...))))
76          #'(begin
77              (define-wrapped-pointer-type name
78                type?
79                wrap-type unwrap-type
80                (lambda (x p)
81                  (format p output-string
82                          (pointer-address (unwrap-type x)))))
83              (define (type-parse wrapped)
84                (let ((unwrapped (unwrap-type wrapped)))
85                  (cond ((= (pointer-address unwrapped) 0)
86                         '())
87                        (else
88                         (parser unwrapped)))))
89              (define-type-contents type-contents type-parse (field-name field-proc) ...)
90              (define-field-reader field-reader type-parse field-proc)
91              ...
92              ))))))
93
94 (define-macro (define-type-contents type-contents type-parse . fields)
95   `(define (,type-contents wrapped)
96      (let ((alist (,type-parse wrapped)))
97        (list ,@(map (lambda (f)
98                       `(cons ',(car f) ,(cadr f)))
99                     fields)))))
100
101 (define-macro (define-field-reader field-reader type-parse body)
102   `(define (,field-reader wrapped)
103      (let ((alist (,type-parse wrapped)))
104        ,body)))
105
106 (define-macro (field name)
107   `(assoc-ref alist ,name))
108
109 (export-syntax define-conversion-type
110                field)
111
112
113 ;;; Support functions for type generation
114
115 (define (bv-uint-ref pointer index)
116   (bytevector-uint-ref
117    (pointer->bytevector pointer 4 index)
118    0
119    (native-endianness)
120    4))
121
122 (define* (array size root #:key (element-size 4) (element-proc bv-uint-ref))
123   (cond ((= (pointer-address root) 0)
124          '())
125         (else
126          (reverse
127           (let loop ((i 0) (res '()))
128             (cond ((= i size)
129                    res)
130                   (else
131                    (loop (+ i 1) (cons (element-proc root (* element-size i)) res)))))))))
132
133 (define (get-element-address root-pointer offset)
134   (make-pointer (+ (pointer-address root-pointer) offset)))
135
136 (define (sized-string s)
137   (cond (s
138          (bytevector->string
139           (u8-list->bytevector (list-head (cadr s) (car s)))
140           (fluid-ref %default-port-encoding)))
141         (else
142          #f)))
143
144 (define (wrap pointers wrap-proc)
145   (define (make-wrap element)
146     (let ((pointer
147            (cond ((pointer? element)
148                   (if (= (pointer-address element) 0)
149                       #f
150                       element))
151                  ((= element 0)
152                   #f)
153                  (else
154                   (make-pointer element)))))
155       (cond (pointer
156              (wrap-proc pointer))
157             (else
158              #f))))
159   (cond ((list? pointers)
160          (map make-wrap pointers))
161         (else
162          (make-wrap pointers))))
163
164 (export array
165         get-element-address
166         sized-string
167         wrap)
168
169
170 ;;; Function Mappers
171
172 (define-syntax define-foreign-function
173   (lambda (x)
174     (syntax-case x (->)
175       ((_ ((foreign-lib name) arg-type ...) -> return-type)
176        (with-syntax ((name-string (datum->syntax x (symbol->string (syntax->datum #'name)))))
177          #'(define name
178              (pointer->procedure return-type
179                                  (dynamic-func name-string foreign-lib)
180                                  (list arg-type ...))))))))
181
182
183 (define libassimp (dynamic-link "libassimp"))
184
185 (define-syntax define-assimp-function
186   (syntax-rules (->)
187     ((_ (name arg-type ...) -> return-type)
188      (define-foreign-function ((libassimp name) arg-type ...) -> return-type))))
189
190
191 (export-syntax define-foreign-function
192                define-assimp-function)
193
194
195 ;;; Enumerators and bitfields (copìed from figl code, thanks to Andy Wingo
196
197 (define-syntax-rule (define-enumeration enumerator (name value) ...)
198   (define-syntax enumerator
199     (lambda (x)
200       (syntax-case x ()
201         ((_)
202          #''(name ...))
203         ((_ enum) (number? (syntax->datum #'enum))
204          #'enum)
205         ((_ enum)
206          #'(or (assq-ref `((name . ,(syntax->datum value)) ...)
207                          (syntax->datum #'enum))
208                (syntax-violation 'enumerator "invalid enumerated value"
209                                  #'enum)))))))
210
211 (define-syntax-rule (define-bitfield bitfield (name value) ...)
212   (define-syntax bitfield
213     (lambda (x)
214       (syntax-case x () 
215         ((_)
216          #''(name ...))
217         ((_ bit (... ...))
218          #`(logior
219             #,@(map
220                 (lambda (bit)
221                   (let ((datum (syntax->datum bit)))
222                     (if (number? datum)
223                         datum
224                         (or (assq-ref '((name . value) ...) datum)
225                             (syntax-violation 'bitfield "invalid bitfield value"
226                                               bit)))))
227                 #'(bit (... ...)))))))))
228
229 (export-syntax define-enumeration
230                define-bitfield)