1 ;;; guile-assimp, foreign interface to libassimp
2 ;;; Copyright (C) 2014 by Javier Sancho Fernandez <jsf at jsancho dot org>
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.
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.
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/>.
18 (define-module (assimp low-level)
19 #:use-module (ice-9 iconv)
20 #:use-module (rnrs bytevectors)
21 #:use-module (system foreign))
26 (define (mk-string . args)
31 (symbol->string (syntax->datum a))))
34 (define (lambda-mk-symbol x)
38 (apply mk-string args)))))
41 ;;; Parsers Definition
43 (define-syntax define-struct-parser
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))
57 (parse-c-struct pointer-or-data (list field-type ...)))))))))))
59 (export-syntax define-struct-parser)
64 (define-syntax define-conversion-type
66 (define mk-symbol (lambda-mk-symbol 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) ...))))
77 (define-wrapped-pointer-type name
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)
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)
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)))
101 (define-macro (define-field-reader field-reader type-parse body)
102 `(define (,field-reader wrapped)
103 (let ((alist (,type-parse wrapped)))
106 (define-macro (field name)
107 `(assoc-ref alist ,name))
109 (export-syntax define-conversion-type
113 ;;; Support functions for type generation
115 (define (bv-uint-ref pointer index)
117 (pointer->bytevector pointer 4 index)
122 (define* (array size root #:key (element-size 4) (element-proc bv-uint-ref))
123 (cond ((= (pointer-address root) 0)
127 (let loop ((i 0) (res '()))
131 (loop (+ i 1) (cons (element-proc root (* element-size i)) res)))))))))
133 (define (get-element-address root-pointer offset)
134 (make-pointer (+ (pointer-address root-pointer) offset)))
136 (define (sized-string s)
139 (u8-list->bytevector (list-head (cadr s) (car s)))
140 (fluid-ref %default-port-encoding)))
144 (define (wrap pointers wrap-proc)
145 (define (make-wrap element)
147 (cond ((pointer? element)
148 (if (= (pointer-address element) 0)
154 (make-pointer element)))))
159 (cond ((list? pointers)
160 (map make-wrap pointers))
162 (make-wrap pointers))))
172 (define-syntax define-foreign-function
175 ((_ ((foreign-lib name) arg-type ...) -> return-type)
176 (with-syntax ((name-string (datum->syntax x (symbol->string (syntax->datum #'name)))))
178 (pointer->procedure return-type
179 (dynamic-func name-string foreign-lib)
180 (list arg-type ...))))))))
183 (define libassimp (dynamic-link "libassimp"))
185 (define-syntax define-assimp-function
187 ((_ (name arg-type ...) -> return-type)
188 (define-foreign-function ((libassimp name) arg-type ...) -> return-type))))
191 (export-syntax define-foreign-function
192 define-assimp-function)
195 ;;; Enumerators and bitfields (copìed from figl code, thanks to Andy Wingo
197 (define-syntax-rule (define-enumeration enumerator (name value) ...)
198 (define-syntax enumerator
203 ((_ enum) (number? (syntax->datum #'enum))
206 #'(or (assq-ref `((name . ,(syntax->datum value)) ...)
207 (syntax->datum #'enum))
208 (syntax-violation 'enumerator "invalid enumerated value"
211 (define-syntax-rule (define-bitfield bitfield (name value) ...)
212 (define-syntax bitfield
221 (let ((datum (syntax->datum bit)))
224 (or (assq-ref '((name . value) ...) datum)
225 (syntax-violation 'bitfield "invalid bitfield value"
227 #'(bit (... ...)))))))))
229 (export-syntax define-enumeration