+ #'(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 (... ...)))))))))