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 ;;; Generic Functions
  25
  26 (define (mk-string . args)
  27   (string-concatenate
  28    (map (lambda (a)
  29           (if (string? a)
  30               a
  31               (symbol->string (syntax->datum a))))
  32         args)))
  33
  34 (define (lambda-mk-symbol x)
  35   (lambda args
  36     (datum->syntax x
  37       (string->symbol
  38        (apply mk-string args)))))
  39
  40
  41 ;;; Parsers Definition
  42
  43 (define-syntax define-struct-parser
  44   (lambda (x)
  45     (syntax-case x ()
  46       ((_ name (field type) ...)
  47        (with-syntax (((field-name ...) (map car #'((field type) ...)))
  48                      ((field-type ...) (map cadr #'((field type) ...))))
  49          #'(define* (name pointer-or-data #:key (reverse #f))
  50              (cond (reverse
  51                     (make-c-struct
  52                      (list field-type ...)
  53                      pointer-or-data))
  54                    (else
  55                     (map cons
  56                          '(field-name ...)
  57                          (parse-c-struct pointer-or-data (list field-type ...)))))))))))
  58
  59 (export-syntax define-struct-parser)
  60
  61
  62 ;;; Type Generation
  63
  64 (define-syntax define-conversion-type
  65   (lambda (x)
  66     (define mk-symbol (lambda-mk-symbol x))
  67     (syntax-case x (->)
  68       ((_ parser -> name (field-name field-proc) ...)
  69        (with-syntax ((type? (mk-symbol #'name "?"))
  70                      (wrap-type (mk-symbol "wrap-" #'name))
  71                      (unwrap-type (mk-symbol "unwrap-" #'name))
  72                      (output-string (mk-string "#<" #'name " ~x>"))
  73                      (type-contents (mk-symbol #'name "-contents"))
  74                      (type-parse (mk-symbol #'name "-parse"))
  75                      ((field-reader ...) (map (lambda (f) (mk-symbol #'name "-" (car f))) #'((field-name field-proc) ...))))
  76          #'(begin
  77              (define-wrapped-pointer-type name
  78                type?
  79                wrap-type unwrap-type
  80                (lambda (x p)
  81                  (format p output-string
  82                          (pointer-address (unwrap-type x)))))
  83              (define (type-parse wrapped)
  84                (let ((unwrapped (unwrap-type wrapped)))
  85                  (cond ((= (pointer-address unwrapped) 0)
  86                         '())
  87                        (else
  88                         (parser unwrapped)))))
  89              (define-type-contents type-contents type-parse (field-name field-proc) ...)
  90              (define-field-reader field-reader type-parse field-proc)
  91              ...
  92              ))))))
  93
  94 (define-macro (define-type-contents type-contents type-parse . fields)
  95   `(define (,type-contents wrapped)
  96      (let ((alist (,type-parse wrapped)))
  97        (list ,@(map (lambda (f)
  98                       `(cons ',(car f) ,(cadr f)))
  99                     fields)))))
 100
 101 (define-macro (define-field-reader field-reader type-parse body)
 102   `(define (,field-reader wrapped)
 103      (let ((alist (,type-parse wrapped)))
 104        ,body)))
 105
 106 (define-macro (field name)
 107   `(assoc-ref alist ,name))
 108
 109 (export-syntax define-conversion-type
 110                field)
 111
 112
 113 ;;; Support functions for type generation
 114
 115 (define (bv-uint-ref pointer index)
 116   (bytevector-uint-ref
 117    (pointer->bytevector pointer 4 index)
 118    0
 119    (native-endianness)
 120    4))
 121
 122 (define* (array size root #:key (element-size 4) (element-proc bv-uint-ref))
 123   (cond ((= (pointer-address root) 0)
 124          '())
 125         (else
 126          (reverse
 127           (let loop ((i 0) (res '()))
 128             (cond ((= i size)
 129                    res)
 130                   (else
 131                    (loop (+ i 1) (cons (element-proc root (* element-size i)) res)))))))))
 132
 133 (define (get-element-address root-pointer offset)
 134   (make-pointer (+ (pointer-address root-pointer) offset)))
 135
 136 (define (sized-string s)
 137   (cond (s
 138          (bytevector->string
 139           (u8-list->bytevector (list-head (cadr s) (car s)))
 140           (fluid-ref %default-port-encoding)))
 141         (else
 142          #f)))
 143
 144 (define (wrap pointers wrap-proc)
 145   (define (make-wrap element)
 146     (let ((pointer
 147            (cond ((pointer? element)
 148                   (if (= (pointer-address element) 0)
 149                       #f
 150                       element))
 151                  ((= element 0)
 152                   #f)
 153                  (else
 154                   (make-pointer element)))))
 155       (cond (pointer
 156              (wrap-proc pointer))
 157             (else
 158              #f))))
 159   (cond ((list? pointers)
 160          (map make-wrap pointers))
 161         (else
 162          (make-wrap pointers))))
 163
 164 (export array
 165         get-element-address
 166         sized-string
 167         wrap)
 168
 169
 170 ;;; Function Mappers
 171
 172 (define-syntax define-foreign-function
 173   (lambda (x)
 174     (syntax-case x (->)
 175       ((_ ((foreign-lib name) arg-type ...) -> return-type)
 176        (with-syntax ((name-string (datum->syntax x (symbol->string (syntax->datum #'name)))))
 177          #'(define name
 178              (pointer->procedure return-type
 179                                  (dynamic-func name-string foreign-lib)
 180                                  (list arg-type ...))))))))
 181
 182
 183 (define libassimp (dynamic-link "libassimp"))
 184
 185 (define-syntax define-assimp-function
 186   (syntax-rules (->)
 187     ((_ (name arg-type ...) -> return-type)
 188      (define-foreign-function ((libassimp name) arg-type ...) -> return-type))))
 189
 190
 191 (export-syntax define-foreign-function
 192                define-assimp-function)
 193
 194
 195 ;;; Enumerators and bitfields (copìed from figl code, thanks to Andy Wingo
 196
 197 (define-syntax-rule (define-enumeration enumerator (name value) ...)
 198   (define-syntax enumerator
 199     (lambda (x)
 200       (syntax-case x ()
 201         ((_)
 202          #''(name ...))
 203         ((_ enum) (number? (syntax->datum #'enum))
 204          #'enum)
 205         ((_ enum)
 206          #'(or (assq-ref `((name . ,(syntax->datum value)) ...)
 207                          (syntax->datum #'enum))
 208                (syntax-violation 'enumerator "invalid enumerated value"
 209                                  #'enum)))))))
 210
 211 (define-syntax-rule (define-bitfield bitfield (name value) ...)
 212   (define-syntax bitfield
 213     (lambda (x)
 214       (syntax-case x ()
 215         ((_)
 216          #''(name ...))
 217         ((_ bit (... ...))
 218          #`(logior
 219             #,@(map
 220                 (lambda (bit)
 221                   (let ((datum (syntax->datum bit)))
 222                     (if (number? datum)
 223                         datum
 224                         (or (assq-ref '((name . value) ...) datum)
 225                             (syntax-violation 'bitfield "invalid bitfield value"
 226                                               bit)))))
 227                 #'(bit (... ...)))))))))
 228
 229 (export-syntax define-enumeration
 230                define-bitfield)