type-specific wrapping and unwrapping of scheme values

* figl/runtime.scm (foreign-trampoline):
  (define-foreign-procedure):
  (define-foreign-type):
  (define-simple-foreign-type): Provide for a way for types to wrap and
  unwrap foreign values.

* figl/glx/types.scm:
* figl/glu/types.scm:
* figl/gl/types.scm: Adapt to define types with the runtime's macros.

diff --git a/figl/gl/types.scm b/figl/gl/types.scm
index 83fe7e7..e40b96b 100644 (file)
--- a/figl/gl/types.scm
+++ b/figl/gl/types.scm
@@ -22,9 +22,10 @@
 ;;; Code:
 
 (define-module (figl gl types)
-  #:use-module (system foreign)
-  #:re-export (void)
-  #:export (GLboolean
+  #:use-module (figl runtime)
+  #:use-module ((system foreign) #:renamer (symbol-prefix-proc 'ffi:))
+  #:export (void
+            GLboolean
             GLbyte
             GLubyte
             GLchar
@@ -69,54 +70,55 @@
             void-*))
 
 (define %ptr
-  (case (sizeof '*)
-    ((4) uint32)
-    ((8) uint64)
+  (case (ffi:sizeof '*)
+    ((4) ffi:uint32)
+    ((8) ffi:uint64)
     (else (error "unknown pointer size"))))
 
-(define GLboolean uint8)
-(define GLbyte int8)
-(define GLubyte uint8)
-(define GLchar int8)
-(define Glshort int16)
-(define GLushort uint16)
-(define GLint int32)
-(define GLuint uint32)
-(define GLsizei int32)
-(define GLenum uint32)
-(define GLintptr %ptr)
-(define GLsizeiptr %ptr)
-(define GLbitfield uint32)
-(define GLfloat float)
-(define GLclampf float)
-(define GLdouble double)
-(define GLclampd double)
+(define-simple-foreign-type void ffi:void)
+(define-simple-foreign-type GLboolean ffi:uint8)
+(define-simple-foreign-type GLbyte ffi:int8)
+(define-simple-foreign-type GLubyte ffi:uint8)
+(define-simple-foreign-type GLchar ffi:int8)
+(define-simple-foreign-type Glshort ffi:int16)
+(define-simple-foreign-type GLushort ffi:uint16)
+(define-simple-foreign-type GLint ffi:int32)
+(define-simple-foreign-type GLuint ffi:uint32)
+(define-simple-foreign-type GLsizei ffi:int32)
+(define-simple-foreign-type GLenum ffi:uint32)
+(define-simple-foreign-type GLintptr %ptr)
+(define-simple-foreign-type GLsizeiptr %ptr)
+(define-simple-foreign-type GLbitfield ffi:uint32)
+(define-simple-foreign-type GLfloat ffi:float)
+(define-simple-foreign-type GLclampf ffi:float)
+(define-simple-foreign-type GLdouble ffi:double)
+(define-simple-foreign-type GLclampd ffi:double)
 
 ;; All of these have different meanings and we should be able to do a
 ;; basic job at teasing them out, but for now, just use the limited
 ;; annotation from (system foreign).
-(define GLboolean-* '*)
-(define GLchar-* '*)
-(define GLdouble-* '*)
-(define GLenum-* '*)
-(define GLfloat-* '*)
-(define GLint-* '*)
-(define GLsizei-* '*)
-(define GLubyte-* '*)
-(define GLuint-* '*)
-(define GLvoid-* '*)
-(define const-GLchar-* '*)
-(define const-GLchar-** '*)
-(define const-GLclampf-* '*)
-(define const-GLdouble-* '*)
-(define const-GLenum-* '*)
-(define const-GLfloat-* '*)
-(define const-GLint-* '*)
-(define const-GLsizei-* '*)
-(define const-GLubyte* '*)
-(define const-GLubyte-* '*)
-(define const-GLubyte-* '*)
-(define const-GLuint-* '*)
-(define const-GLvoid-* '*)
-(define const-GLvoid-** '*)
-(define void-* '*)
+(define-simple-foreign-type GLboolean-* '*)
+(define-simple-foreign-type GLchar-* '*)
+(define-simple-foreign-type GLdouble-* '*)
+(define-simple-foreign-type GLenum-* '*)
+(define-simple-foreign-type GLfloat-* '*)
+(define-simple-foreign-type GLint-* '*)
+(define-simple-foreign-type GLsizei-* '*)
+(define-simple-foreign-type GLubyte-* '*)
+(define-simple-foreign-type GLuint-* '*)
+(define-simple-foreign-type GLvoid-* '*)
+(define-simple-foreign-type const-GLchar-* '*)
+(define-simple-foreign-type const-GLchar-** '*)
+(define-simple-foreign-type const-GLclampf-* '*)
+(define-simple-foreign-type const-GLdouble-* '*)
+(define-simple-foreign-type const-GLenum-* '*)
+(define-simple-foreign-type const-GLfloat-* '*)
+(define-simple-foreign-type const-GLint-* '*)
+(define-simple-foreign-type const-GLsizei-* '*)
+(define-simple-foreign-type const-GLubyte* '*)
+(define-simple-foreign-type const-GLubyte-* '*)
+(define-simple-foreign-type const-GLubyte-* '*)
+(define-simple-foreign-type const-GLuint-* '*)
+(define-simple-foreign-type const-GLvoid-* '*)
+(define-simple-foreign-type const-GLvoid-** '*)
+(define-simple-foreign-type void-* '*)

diff --git a/figl/glu/types.scm b/figl/glu/types.scm
index c0fddfe..b7b12a2 100644 (file)
--- a/figl/glu/types.scm
+++ b/figl/glu/types.scm
@@ -22,6 +22,7 @@
 ;;; Code:
 
 (define-module (figl glu types)
+  #:use-module (figl runtime)
   #:export (GLUnurbs*
             GLUquadric*
             GLUtesselator*
@@ -34,11 +35,11 @@
 (module-use! (module-public-interface (current-module))
              (resolve-interface '(figl gl types)))
 
-(define GLUnurbs* '*)
-(define GLUquadric* '*)
-(define GLUtesselator* '*)
-(define GLdouble* '*)
-(define GLfloat* '*)
-(define GLvoid* '*)
-(define _GLUfuncptr '*)
-(define const-void-* '*)
+(define-simple-foreign-type GLUnurbs* '*)
+(define-simple-foreign-type GLUquadric* '*)
+(define-simple-foreign-type GLUtesselator* '*)
+(define-simple-foreign-type GLdouble* '*)
+(define-simple-foreign-type GLfloat* '*)
+(define-simple-foreign-type GLvoid* '*)
+(define-simple-foreign-type _GLUfuncptr '*)
+(define-simple-foreign-type const-void-* '*)

diff --git a/figl/glx/types.scm b/figl/glx/types.scm
index 37f972e..f8c46b8 100644 (file)
--- a/figl/glx/types.scm
+++ b/figl/glx/types.scm
@@ -22,9 +22,11 @@
 ;;; Code:
 
 (define-module (figl glx types)
-  #:use-module (system foreign)
-  #:re-export (int unsigned-long)
-  #:export (Bool
+  #:use-module ((system foreign) #:renamer (symbol-prefix-proc 'ffi:))
+  #:use-module (figl runtime)
+  #:export (int
+            unsigned-long
+            Bool
             Display-*
             Font
             GLXContext
@@ -52,27 +54,29 @@
 (module-use! (module-public-interface (current-module))
              (resolve-interface '(figl gl types)))
 
-(define Bool int)
-(define Display-* '*)
-(define Font unsigned-long)
-(define GLXContext '*)
-(define const-GLXContext '*)
-(define GLXContextID '*)
-(define GLXDrawable unsigned-long)
-(define GLXFBConfig '*)
-(define GLXFBConfig-* '*)
-(define GLXFBConfig-* '*)
-(define GLXPbuffer unsigned-long)
-(define GLXPixmap unsigned-long)
-(define GLXWindow unsigned-long)
-(define Pixmap unsigned-long)
-(define Window unsigned-long)
-(define XVisualInfo* '*)
-(define XVisualInfo-* '*)
-(define const-char-* '*)
-(define const-int-* '*)
-(define int-* '*)
-(define unsigned-int-* '*)
-(define unsigned-long-* '*)
+(define-simple-foreign-type int ffi:int)
+(define-simple-foreign-type unsigned-long ffi:unsigned-long)
+(define-simple-foreign-type Bool ffi:int)
+(define-simple-foreign-type Display-* '*)
+(define-simple-foreign-type Font ffi:unsigned-long)
+(define-simple-foreign-type GLXContext '*)
+(define-simple-foreign-type const-GLXContext '*)
+(define-simple-foreign-type GLXContextID '*)
+(define-simple-foreign-type GLXDrawable ffi:unsigned-long)
+(define-simple-foreign-type GLXFBConfig '*)
+(define-simple-foreign-type GLXFBConfig-* '*)
+(define-simple-foreign-type GLXFBConfig-* '*)
+(define-simple-foreign-type GLXPbuffer ffi:unsigned-long)
+(define-simple-foreign-type GLXPixmap ffi:unsigned-long)
+(define-simple-foreign-type GLXWindow ffi:unsigned-long)
+(define-simple-foreign-type Pixmap ffi:unsigned-long)
+(define-simple-foreign-type Window ffi:unsigned-long)
+(define-simple-foreign-type XVisualInfo* '*)
+(define-simple-foreign-type XVisualInfo-* '*)
+(define-simple-foreign-type const-char-* '*)
+(define-simple-foreign-type const-int-* '*)
+(define-simple-foreign-type int-* '*)
+(define-simple-foreign-type unsigned-int-* '*)
+(define-simple-foreign-type unsigned-long-* '*)
 ;; void(*)()
-(define #{void\x28;*\x29;\x28;\x29;}# '*)
+(define-simple-foreign-type #{void\x28;*\x29;\x28;\x29;}# '*)

diff --git a/figl/runtime.scm b/figl/runtime.scm
index e50f1c8..2e32f78 100644 (file)
--- a/figl/runtime.scm
+++ b/figl/runtime.scm
@@ -25,7 +25,9 @@
   #:use-module (system foreign)
   #:export (current-resolver
             define-foreign-procedure
-            define-foreign-procedures))
+            define-foreign-procedures
+            define-foreign-type
+            define-simple-foreign-type))
 
 (define (default-resolver name)
   (dynamic-pointer name (dynamic-link)))
@@ -45,9 +47,9 @@
          #'(lambda (pname ...)
              (let ((ptr (resolve sname)))
                (set! trampoline
-                     (pointer->procedure type
+                     (pointer->procedure (type)
                                          ptr
-                                         (list ptype ...)))
+                                         (list (ptype) ...)))
                (trampoline pname ...))))))))
 
 (define-syntax define-foreign-procedure
@@ -60,7 +62,9 @@
                                      name (pname ptype) ... -> type))
                 (name (lambda (pname ...)
                         docstring
-                        (trampoline pname ...))))
+                        (let ((pname (ptype #:unwrap pname))
+                              ...)
+                          (type #:wrap (trampoline pname ...))))))
          name)))))
 
 (define-syntax define-foreign-procedures
@@ -71,3 +75,36 @@
        (define-foreign-procedure (name prototype ...)
          docstring)
        ...))))
+
+(define-syntax define-foreign-type
+  (syntax-rules ()
+    ((_ name ffi-type unwrap wrap)
+     (define-syntax name
+       (syntax-rules ()
+         ((_) ffi-type)
+         ((_ #:wrap x) (wrap x))
+         ((_ #:unwrap x) (unwrap x)))))))
+
+(define-syntax define-simple-foreign-type
+  (syntax-rules ()
+    ((_ name ffi-type)
+     ;; We could dispatch through to define-foreign-type via:
+     ;;
+     ;;   (define-foreign-type name
+     ;;     ffi-type
+     ;;     (lambda (x) x)
+     ;;     (lambda (x) x))
+     ;;
+     ;; However the resulting wrap expression:
+     ;;
+     ;;   ((lambda (x) x) (trampoline arg ...))
+     ;;
+     ;; would not be in tail position, as the optimizer doesn't know
+     ;; that the foreign function just returns one value.  This hack
+     ;; just passes the wrapped expression through, allowing it to be in
+     ;; tail position.
+     (define-syntax name
+       (syntax-rules ()
+         ((_) ffi-type)
+         ((_ #:wrap x) x)
+         ((_ #:unwrap x) x))))))