X-Git-Url: https://git.jsancho.org/?a=blobdiff_plain;f=src%2Flow-level.scm;h=fd7af9ddea932881e7decdd718c69107d0bde48a;hb=708fbd4d04091af33626837f4a5141d20748762d;hp=53bb39eb4d83906996191061a09dc729fc9f573d;hpb=cc3b67814bd3d1d26e1d1d5523db7bf19384bf33;p=guile-assimp.git

diff --git a/src/low-level.scm b/src/low-level.scm
index 53bb39e..fd7af9d 100644
--- a/src/low-level.scm
+++ b/src/low-level.scm
@@ -21,6 +21,21 @@
   #: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
@@ -29,10 +44,15 @@
       ((_ 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)
 
@@ -41,17 +61,7 @@
 
 (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 "?"))
@@ -111,12 +121,12 @@
   (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)))
@@ -153,3 +163,18 @@
 	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 ...))))))))
+
+(export-syntax define-foreign-function)