update upstream sources

[clinton/guile-figl.git] / figl / runtime.scm

diff --git a/figl/runtime.scm b/figl/runtime.scm
index 2e32f78..d4515e8 100644 (file)
--- a/figl/runtime.scm
+++ b/figl/runtime.scm
@@ -23,43 +23,32 @@
 
 (define-module (figl runtime)
   #:use-module (system foreign)
-  #:export (current-resolver
-            define-foreign-procedure
+  #:export (define-foreign-procedure
             define-foreign-procedures
             define-foreign-type
-            define-simple-foreign-type))
-
-(define (default-resolver name)
-  (dynamic-pointer name (dynamic-link)))
-
-(define current-resolver
-  (make-parameter default-resolver))
-
-(define (resolve name)
-  ((current-resolver) name))
+            define-simple-foreign-type
+            define-enumeration
+            define-bitfield))
 
 (define-syntax foreign-trampoline
-  (lambda (stx)
-    (syntax-case stx (->)
-      ((_ trampoline
-          name (pname ptype) ... -> type)
-       (with-syntax ((sname (symbol->string (syntax->datum #'name))))
-         #'(lambda (pname ...)
-             (let ((ptr (resolve sname)))
-               (set! trampoline
-                     (pointer->procedure (type)
-                                         ptr
-                                         (list (ptype) ...)))
-               (trampoline pname ...))))))))
+  (syntax-rules (->)
+    ((_ trampoline resolve-name (pname ptype) ... -> type)
+     (lambda (pname ...)
+       (set! trampoline
+             (pointer->procedure (type)
+                                 resolve-name
+                                 (list (ptype) ...)))
+       (trampoline pname ...)))))
 
 (define-syntax define-foreign-procedure
   (syntax-rules (->)
     ((define-foreign-procedure (name (pname ptype) ... -> type)
+       resolve-name
        docstring)
      (define name
        (letrec ((trampoline
-                 (foreign-trampoline trampoline
-                                     name (pname ptype) ... -> type))
+                 (foreign-trampoline trampoline resolve-name
+                                     (pname ptype) ... -> type))
                 (name (lambda (pname ...)
                         docstring
                         (let ((pname (ptype #:unwrap pname))
@@ -70,9 +59,11 @@
 (define-syntax define-foreign-procedures
   (syntax-rules ()
     ((define-foreign-procedures ((name prototype ...) ...)
+       resolve-name
        docstring)
      (begin
        (define-foreign-procedure (name prototype ...)
+         resolve-name
          docstring)
        ...))))
 
@@ -108,3 +99,35 @@
          ((_) ffi-type)
          ((_ #:wrap x) x)
          ((_ #:unwrap x) x))))))
+
+(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 . 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 (... ...)))))))))