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))
24 ;;; Parsers Definition
26 (define-syntax define-struct-parser
29 ((_ name (field type) ...)
30 (with-syntax (((field-name ...) (map car #'((field type) ...)))
31 ((field-type ...) (map cadr #'((field type) ...))))
32 #'(define (name pointer)
35 (parse-c-struct pointer (list field-type ...)))))))))
37 (export-syntax define-struct-parser)
42 (define-syntax define-conversion-type
44 (define (mk-string . args)
49 (symbol->string (syntax->datum a))))
51 (define (mk-symbol . args)
54 (apply mk-string args))))
56 ((_ parser -> name (field-name field-proc) ...)
57 (with-syntax ((type? (mk-symbol #'name "?"))
58 (wrap-type (mk-symbol "wrap-" #'name))
59 (unwrap-type (mk-symbol "unwrap-" #'name))
60 (output-string (mk-string "#<" #'name " ~x>"))
61 (type-contents (mk-symbol #'name "-contents"))
62 (type-parse (mk-symbol #'name "-parse"))
63 ((field-reader ...) (map (lambda (f) (mk-symbol #'name "-" (car f))) #'((field-name field-proc) ...))))
65 (define-wrapped-pointer-type name
69 (format p output-string
70 (pointer-address (unwrap-type x)))))
71 (define (type-parse wrapped)
72 (let ((unwrapped (unwrap-type wrapped)))
73 (cond ((= (pointer-address unwrapped) 0)
76 (parser unwrapped)))))
77 (define-type-contents type-contents type-parse (field-name field-proc) ...)
78 (define-field-reader field-reader type-parse field-proc)
82 (define-macro (define-type-contents type-contents type-parse . fields)
83 `(define (,type-contents wrapped)
84 (let ((alist (,type-parse wrapped)))
85 (list ,@(map (lambda (f)
86 `(cons ',(car f) ,(cadr f)))
89 (define-macro (define-field-reader field-reader type-parse body)
90 `(define (,field-reader wrapped)
91 (let ((alist (,type-parse wrapped)))
94 (define-macro (field name)
95 `(assoc-ref alist ,name))
97 (export-syntax define-conversion-type
101 ;;; Support functions for type generation
103 (define (bv-uint-ref pointer index)
105 (pointer->bytevector pointer 4 index)
110 (define* (array size root #:key (element-size 4) (element-proc bv-uint-ref))
111 (cond ((= (pointer-address root) 0)
118 (cons (element-proc root (* element-size i))
119 (loop (+ i 1)))))))))
121 (define (get-element-address root-pointer offset)
122 (make-pointer (+ (pointer-address root-pointer) offset)))
124 (define (sized-string s)
127 (u8-list->bytevector (list-head (cadr s) (car s)))
128 (fluid-ref %default-port-encoding)))
132 (define (wrap pointers wrap-proc)
133 (define (make-wrap element)
135 (cond ((pointer? element)
136 (if (= (pointer-address element) 0)
142 (make-pointer element)))))
147 (cond ((list? pointers)
148 (map make-wrap pointers))
150 (make-wrap pointers))))