#: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
((_ name (field type) ...)
(with-syntax (((field-name ...) (map car #'((field type) ...)))
((field-type ...) (map cadr #'((field type) ...))))
- #'(define (name pointer)
- (map cons
- '(field-name ...)
- (parse-c-struct pointer (list 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)
(define-syntax define-conversion-type
(lambda (x)
- (define (mk-string . args)
- (string-concatenate
- (map (lambda (a)
- (if (string? a)
- a
- (symbol->string (syntax->datum a))))
- args)))
- (define (mk-symbol . args)
- (datum->syntax x
- (string->symbol
- (apply mk-string args))))
+ (define mk-symbol (lambda-mk-symbol x))
(syntax-case x (->)
((_ parser -> name (field-name field-proc) ...)
(with-syntax ((type? (mk-symbol #'name "?"))
(cond ((= (pointer-address root) 0)
'())
(else
- (let loop ((i 0))
- (cond ((= i size)
- '())
- (else
- (cons (element-proc root (* element-size i))
- (loop (+ i 1)))))))))
+ (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)))
(dynamic-func name-string foreign-lib)
(list arg-type ...))))))))
-(export-syntax define-foreign-function)
+
+(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)