src/low-level.scm

   1 ;;; guile-assimp, foreign interface to libassimp
   2 ;;; Copyright (C) 2014 by Javier Sancho Fernandez <jsf at jsancho dot org>
   3 ;;;
   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.
   8 ;;;
   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.
  13 ;;;
  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/>.
  16
  17
  18 (define-module (assimp low-level)
  19   #:use-module (ice-9 iconv)
  20   #:use-module (rnrs bytevectors)
  21   #:use-module (system foreign))
  22
  23
  24 ;;; Parsers Definition
  25
  26 (define-syntax define-struct-parser
  27   (lambda (x)
  28     (syntax-case x ()
  29       ((_ name (field type) ...)
  30        (with-syntax (((field-name ...) (map car #'((field type) ...)))
  31                      ((field-type ...) (map cadr #'((field type) ...))))
  32          #'(define (name pointer)
  33              (map cons
  34                   '(field-name ...)
  35                   (parse-c-struct pointer (list field-type ...)))))))))
  36
  37 (export-syntax define-struct-parser)
  38
  39
  40 ;;; Type Generation
  41
  42 (define-syntax define-conversion-type
  43   (lambda (x)
  44     (define (mk-string . args)
  45       (string-concatenate
  46        (map (lambda (a)
  47               (if (string? a)
  48                   a
  49                   (symbol->string (syntax->datum a))))
  50             args)))
  51     (define (mk-symbol . args)
  52       (datum->syntax x
  53         (string->symbol
  54          (apply mk-string args))))
  55     (syntax-case x (->)
  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) ...))))
  64          #'(begin
  65              (define-wrapped-pointer-type name
  66                type?
  67                wrap-type unwrap-type
  68                (lambda (x p)
  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)
  74                         '())
  75                        (else
  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)
  79              ...
  80              ))))))
  81
  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)))
  87                     fields)))))
  88
  89 (define-macro (define-field-reader field-reader type-parse body)
  90   `(define (,field-reader wrapped)
  91      (let ((alist (,type-parse wrapped)))
  92        ,body)))
  93
  94 (define-macro (field name)
  95   `(assoc-ref alist ,name))
  96
  97 (export-syntax define-conversion-type
  98                field)
  99
 100
 101 ;;; Support functions for type generation
 102
 103 (define (bv-uint-ref pointer index)
 104   (bytevector-uint-ref
 105    (pointer->bytevector pointer 4 index)
 106    0
 107    (native-endianness)
 108    4))
 109
 110 (define* (array size root #:key (element-size 4) (element-proc bv-uint-ref))
 111   (cond ((= (pointer-address root) 0)
 112          '())
 113         (else
 114          (let loop ((i 0))
 115            (cond ((= i size)
 116                   '())
 117                  (else
 118                   (cons (element-proc root (* element-size i))
 119                         (loop (+ i 1)))))))))
 120
 121 (define (get-element-address root-pointer offset)
 122   (make-pointer (+ (pointer-address root-pointer) offset)))
 123
 124 (define (sized-string s)
 125   (cond (s
 126          (bytevector->string
 127           (u8-list->bytevector (list-head (cadr s) (car s)))
 128           (fluid-ref %default-port-encoding)))
 129         (else
 130          #f)))
 131
 132 (define (wrap pointers wrap-proc)
 133   (define (make-wrap element)
 134     (let ((pointer
 135            (cond ((pointer? element)
 136                   (if (= (pointer-address element) 0)
 137                       #f
 138                       element))
 139                  ((= element 0)
 140                   #f)
 141                  (else
 142                   (make-pointer element)))))
 143       (cond (pointer
 144              (wrap-proc pointer))
 145             (else
 146              #f))))
 147   (cond ((list? pointers)
 148          (map make-wrap pointers))
 149         (else
 150          (make-wrap pointers))))
 151
 152 (export array
 153         get-element-address
 154         sized-string
 155         wrap)
 156
 157
 158 ;;; Function Mappers
 159
 160 (define-syntax define-foreign-function
 161   (lambda (x)
 162     (syntax-case x (->)
 163       ((_ ((foreign-lib name) arg-type ...) -> return-type)
 164        (with-syntax ((name-string (datum->syntax x (symbol->string (syntax->datum #'name)))))
 165          #'(define name
 166              (pointer->procedure return-type
 167                                  (dynamic-func name-string foreign-lib)
 168                                  (list arg-type ...))))))))
 169
 170 (export-syntax define-foreign-function)