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 (define (mk-string . args)
  25   (string-concatenate
  26    (map (lambda (a)
  27           (if (string? a)
  28               a
  29               (symbol->string (syntax->datum a))))
  30         args)))
  31
  32 (define (lambda-mk-symbol x)
  33   (lambda args
  34     (datum->syntax x
  35       (string->symbol
  36        (apply mk-string args)))))
  37
  38
  39 ;;; Parsers Definition
  40
  41 (define-syntax define-struct-parser
  42   (lambda (x)
  43     (syntax-case x ()
  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))
  48              (cond (reverse
  49                     (make-c-struct
  50                      (list field-type ...)
  51                      pointer-or-data))
  52                    (else
  53                     (map cons
  54                          '(field-name ...)
  55                          (parse-c-struct pointer-or-data (list field-type ...)))))))))))
  56
  57 (export-syntax define-struct-parser)
  58
  59
  60 ;;; Type Generation
  61
  62 (define-syntax define-conversion-type
  63   (lambda (x)
  64     (define mk-symbol (lambda-mk-symbol x))
  65     (syntax-case 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) ...))))
  74          #'(begin
  75              (define-wrapped-pointer-type name
  76                type?
  77                wrap-type unwrap-type
  78                (lambda (x p)
  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)
  84                         '())
  85                        (else
  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)
  89              ...
  90              ))))))
  91
  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)))
  97                     fields)))))
  98
  99 (define-macro (define-field-reader field-reader type-parse body)
 100   `(define (,field-reader wrapped)
 101      (let ((alist (,type-parse wrapped)))
 102        ,body)))
 103
 104 (define-macro (field name)
 105   `(assoc-ref alist ,name))
 106
 107 (export-syntax define-conversion-type
 108                field)
 109
 110
 111 ;;; Support functions for type generation
 112
 113 (define (bv-uint-ref pointer index)
 114   (bytevector-uint-ref
 115    (pointer->bytevector pointer 4 index)
 116    0
 117    (native-endianness)
 118    4))
 119
 120 (define* (array size root #:key (element-size 4) (element-proc bv-uint-ref))
 121   (cond ((= (pointer-address root) 0)
 122          '())
 123         (else
 124          (reverse
 125           (let loop ((i 0) (res '()))
 126             (cond ((= i size)
 127                    res)
 128                   (else
 129                    (loop (+ i 1) (cons (element-proc root (* element-size i)) res)))))))))
 130
 131 (define (get-element-address root-pointer offset)
 132   (make-pointer (+ (pointer-address root-pointer) offset)))
 133
 134 (define (sized-string s)
 135   (cond (s
 136          (bytevector->string
 137           (u8-list->bytevector (list-head (cadr s) (car s)))
 138           (fluid-ref %default-port-encoding)))
 139         (else
 140          #f)))
 141
 142 (define (wrap pointers wrap-proc)
 143   (define (make-wrap element)
 144     (let ((pointer
 145            (cond ((pointer? element)
 146                   (if (= (pointer-address element) 0)
 147                       #f
 148                       element))
 149                  ((= element 0)
 150                   #f)
 151                  (else
 152                   (make-pointer element)))))
 153       (cond (pointer
 154              (wrap-proc pointer))
 155             (else
 156              #f))))
 157   (cond ((list? pointers)
 158          (map make-wrap pointers))
 159         (else
 160          (make-wrap pointers))))
 161
 162 (export array
 163         get-element-address
 164         sized-string
 165         wrap)
 166
 167
 168 ;;; Function Mappers
 169
 170 (define-syntax define-foreign-function
 171   (lambda (x)
 172     (syntax-case x (->)
 173       ((_ ((foreign-lib name) arg-type ...) -> return-type)
 174        (with-syntax ((name-string (datum->syntax x (symbol->string (syntax->datum #'name)))))
 175          #'(define name
 176              (pointer->procedure return-type
 177                                  (dynamic-func name-string foreign-lib)
 178                                  (list arg-type ...))))))))
 179
 180 (export-syntax define-foreign-function)