X-Git-Url: https://git.jsancho.org/?p=guile-assimp.git;a=blobdiff_plain;f=assimp%2Flow-level.scm;fp=assimp%2Flow-level.scm;h=0000000000000000000000000000000000000000;hp=148b26d9b102e5e41b5824c9d095f3785921e54b;hb=ceafd0037f102ffbb2b902b6ccb0b9701f3ae1ba;hpb=1dc327bbc4a576fdc5c160325d86b5b32754139b diff --git a/assimp/low-level.scm b/assimp/low-level.scm deleted file mode 100644 index 148b26d..0000000 --- a/assimp/low-level.scm +++ /dev/null @@ -1,230 +0,0 @@ -;;; guile-assimp, foreign interface to libassimp -;;; Copyright (C) 2014 by Javier Sancho Fernandez -;;; -;;; 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 . - - -(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)