#:use-module (system foreign))
+(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)))