X-Git-Url: https://git.jsancho.org/?a=blobdiff_plain;f=src%2Flow-level.scm;h=148b26d9b102e5e41b5824c9d095f3785921e54b;hb=d90f35ebd1816b818700badf108882040e82c5cb;hp=d604789712e14939ca66c66fa64c3a1cb4baf6b3;hpb=0c88b5e31475e07d0d06ae9af01ad05a0efdc875;p=guile-assimp.git

diff --git a/src/low-level.scm b/src/low-level.scm
index d604789..148b26d 100644
--- a/src/low-level.scm
+++ b/src/low-level.scm
@@ -21,6 +21,23 @@
   #: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
@@ -29,10 +46,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 +63,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 "?"))
@@ -167,4 +179,52 @@
 				 (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)