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 (define (mk-string . args)
29 (symbol->string (syntax->datum a))))
32 (define (lambda-mk-symbol x)
36 (apply mk-string args)))))
39 ;;; Parsers Definition
41 (define-syntax define-struct-parser
44 ((_ name (field type) ...)
45 (with-syntax (((field-name ...) (map car #'((field type) ...)))
46 ((field-type ...) (map cadr #'((field type) ...))))
47 #'(define* (name pointer-or-data #:key (reverse #f))
55 (parse-c-struct pointer-or-data (list field-type ...)))))))))))
57 (export-syntax define-struct-parser)
62 (define-syntax define-conversion-type
64 (define mk-symbol (lambda-mk-symbol x))
66 ((_ parser -> name (field-name field-proc) ...)
67 (with-syntax ((type? (mk-symbol #'name "?"))
68 (wrap-type (mk-symbol "wrap-" #'name))
69 (unwrap-type (mk-symbol "unwrap-" #'name))
70 (output-string (mk-string "#<" #'name " ~x>"))
71 (type-contents (mk-symbol #'name "-contents"))
72 (type-parse (mk-symbol #'name "-parse"))
73 ((field-reader ...) (map (lambda (f) (mk-symbol #'name "-" (car f))) #'((field-name field-proc) ...))))
75 (define-wrapped-pointer-type name
79 (format p output-string
80 (pointer-address (unwrap-type x)))))
81 (define (type-parse wrapped)
82 (let ((unwrapped (unwrap-type wrapped)))
83 (cond ((= (pointer-address unwrapped) 0)
86 (parser unwrapped)))))
87 (define-type-contents type-contents type-parse (field-name field-proc) ...)
88 (define-field-reader field-reader type-parse field-proc)
92 (define-macro (define-type-contents type-contents type-parse . fields)
93 `(define (,type-contents wrapped)
94 (let ((alist (,type-parse wrapped)))
95 (list ,@(map (lambda (f)
96 `(cons ',(car f) ,(cadr f)))
99 (define-macro (define-field-reader field-reader type-parse body)
100 `(define (,field-reader wrapped)
101 (let ((alist (,type-parse wrapped)))
104 (define-macro (field name)
105 `(assoc-ref alist ,name))
107 (export-syntax define-conversion-type
111 ;;; Support functions for type generation
113 (define (bv-uint-ref pointer index)
115 (pointer->bytevector pointer 4 index)
120 (define* (array size root #:key (element-size 4) (element-proc bv-uint-ref))
121 (cond ((= (pointer-address root) 0)
125 (let loop ((i 0) (res '()))
129 (loop (+ i 1) (cons (element-proc root (* element-size i)) res)))))))))
131 (define (get-element-address root-pointer offset)
132 (make-pointer (+ (pointer-address root-pointer) offset)))
134 (define (sized-string s)
137 (u8-list->bytevector (list-head (cadr s) (car s)))
138 (fluid-ref %default-port-encoding)))
142 (define (wrap pointers wrap-proc)
143 (define (make-wrap element)
145 (cond ((pointer? element)
146 (if (= (pointer-address element) 0)
152 (make-pointer element)))))
157 (cond ((list? pointers)
158 (map make-wrap pointers))
160 (make-wrap pointers))))
170 (define-syntax define-foreign-function
173 ((_ ((foreign-lib name) arg-type ...) -> return-type)
174 (with-syntax ((name-string (datum->syntax x (symbol->string (syntax->datum #'name)))))
176 (pointer->procedure return-type
177 (dynamic-func name-string foreign-lib)
178 (list arg-type ...))))))))
180 (export-syntax define-foreign-function)