+++ /dev/null
-;;; guile-assimp, foreign interface to libassimp
-;;; Copyright (C) 2014 by Javier Sancho Fernandez <jsf at jsancho dot org>
-;;;
-;;; This program is free software: you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation, either version 3 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; This program is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-
-(define-module (assimp low-level)
- #:use-module (ice-9 iconv)
- #:use-module (rnrs bytevectors)
- #:use-module (system foreign))
-
-
-;;; Generic Functions
-
-(define (mk-string . args)
- (string-concatenate
- (map (lambda (a)
- (if (string? a)
- a
- (symbol->string (syntax->datum a))))
- args)))
-
-(define (lambda-mk-symbol x)
- (lambda args
- (datum->syntax x
- (string->symbol
- (apply mk-string args)))))
-
-
-;;; Parsers Definition
-
-(define-syntax define-struct-parser
- (lambda (x)
- (syntax-case x ()
- ((_ name (field type) ...)
- (with-syntax (((field-name ...) (map car #'((field type) ...)))
- ((field-type ...) (map cadr #'((field type) ...))))
- #'(define* (name pointer-or-data #:key (reverse #f))
- (cond (reverse
- (make-c-struct
- (list field-type ...)
- pointer-or-data))
- (else
- (map cons
- '(field-name ...)
- (parse-c-struct pointer-or-data (list field-type ...)))))))))))
-
-(export-syntax define-struct-parser)
-
-
-;;; Type Generation
-
-(define-syntax define-conversion-type
- (lambda (x)
- (define mk-symbol (lambda-mk-symbol x))
- (syntax-case x (->)
- ((_ parser -> name (field-name field-proc) ...)
- (with-syntax ((type? (mk-symbol #'name "?"))
- (wrap-type (mk-symbol "wrap-" #'name))
- (unwrap-type (mk-symbol "unwrap-" #'name))
- (output-string (mk-string "#<" #'name " ~x>"))
- (type-contents (mk-symbol #'name "-contents"))
- (type-parse (mk-symbol #'name "-parse"))
- ((field-reader ...) (map (lambda (f) (mk-symbol #'name "-" (car f))) #'((field-name field-proc) ...))))
- #'(begin
- (define-wrapped-pointer-type name
- type?
- wrap-type unwrap-type
- (lambda (x p)
- (format p output-string
- (pointer-address (unwrap-type x)))))
- (define (type-parse wrapped)
- (let ((unwrapped (unwrap-type wrapped)))
- (cond ((= (pointer-address unwrapped) 0)
- '())
- (else
- (parser unwrapped)))))
- (define-type-contents type-contents type-parse (field-name field-proc) ...)
- (define-field-reader field-reader type-parse field-proc)
- ...
- ))))))
-
-(define-macro (define-type-contents type-contents type-parse . fields)
- `(define (,type-contents wrapped)
- (let ((alist (,type-parse wrapped)))
- (list ,@(map (lambda (f)
- `(cons ',(car f) ,(cadr f)))
- fields)))))
-
-(define-macro (define-field-reader field-reader type-parse body)
- `(define (,field-reader wrapped)
- (let ((alist (,type-parse wrapped)))
- ,body)))
-
-(define-macro (field name)
- `(assoc-ref alist ,name))
-
-(export-syntax define-conversion-type
- field)
-
-
-;;; Support functions for type generation
-
-(define (bv-uint-ref pointer index)
- (bytevector-uint-ref
- (pointer->bytevector pointer 4 index)
- 0
- (native-endianness)
- 4))
-
-(define* (array size root #:key (element-size 4) (element-proc bv-uint-ref))
- (cond ((= (pointer-address root) 0)
- '())
- (else
- (reverse
- (let loop ((i 0) (res '()))
- (cond ((= i size)
- res)
- (else
- (loop (+ i 1) (cons (element-proc root (* element-size i)) res)))))))))
-
-(define (get-element-address root-pointer offset)
- (make-pointer (+ (pointer-address root-pointer) offset)))
-
-(define (sized-string s)
- (cond (s
- (bytevector->string
- (u8-list->bytevector (list-head (cadr s) (car s)))
- (fluid-ref %default-port-encoding)))
- (else
- #f)))
-
-(define (wrap pointers wrap-proc)
- (define (make-wrap element)
- (let ((pointer
- (cond ((pointer? element)
- (if (= (pointer-address element) 0)
- #f
- element))
- ((= element 0)
- #f)
- (else
- (make-pointer element)))))
- (cond (pointer
- (wrap-proc pointer))
- (else
- #f))))
- (cond ((list? pointers)
- (map make-wrap pointers))
- (else
- (make-wrap pointers))))
-
-(export array
- get-element-address
- sized-string
- wrap)
-
-
-;;; Function Mappers
-
-(define-syntax define-foreign-function
- (lambda (x)
- (syntax-case x (->)
- ((_ ((foreign-lib name) arg-type ...) -> return-type)
- (with-syntax ((name-string (datum->syntax x (symbol->string (syntax->datum #'name)))))
- #'(define name
- (pointer->procedure return-type
- (dynamic-func name-string foreign-lib)
- (list arg-type ...))))))))
-
-
-(define libassimp (dynamic-link "libassimp"))
-
-(define-syntax define-assimp-function
- (syntax-rules (->)
- ((_ (name arg-type ...) -> return-type)
- (define-foreign-function ((libassimp name) arg-type ...) -> return-type))))
-
-
-(export-syntax define-foreign-function
- define-assimp-function)
-
-
-;;; Enumerators and bitfields (copìed from figl code, thanks to Andy Wingo
-
-(define-syntax-rule (define-enumeration enumerator (name value) ...)
- (define-syntax enumerator
- (lambda (x)
- (syntax-case x ()
- ((_)
- #''(name ...))
- ((_ enum) (number? (syntax->datum #'enum))
- #'enum)
- ((_ enum)
- #'(or (assq-ref `((name . ,(syntax->datum value)) ...)
- (syntax->datum #'enum))
- (syntax-violation 'enumerator "invalid enumerated value"
- #'enum)))))))
-
-(define-syntax-rule (define-bitfield bitfield (name value) ...)
- (define-syntax bitfield
- (lambda (x)
- (syntax-case x ()
- ((_)
- #''(name ...))
- ((_ bit (... ...))
- #`(logior
- #,@(map
- (lambda (bit)
- (let ((datum (syntax->datum bit)))
- (if (number? datum)
- datum
- (or (assq-ref '((name . value) ...) datum)
- (syntax-violation 'bitfield "invalid bitfield value"
- bit)))))
- #'(bit (... ...)))))))))
-
-(export-syntax define-enumeration
- define-bitfield)
projects / guile-assimp.git / blobdiff