From 93f72ad8a53530f768f6ae2562c442aaf17532e4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 2 Feb 2013 21:38:31 +0100 Subject: [PATCH] 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. --- figl/gl/types.scm | 98 +++++++++++++++++++++++----------------------- figl/glu/types.scm | 17 ++++---- figl/glx/types.scm | 56 ++++++++++++++------------ figl/runtime.scm | 45 +++++++++++++++++++-- 4 files changed, 130 insertions(+), 86 deletions(-) diff --git a/figl/gl/types.scm b/figl/gl/types.scm index 83fe7e7..e40b96b 100644 --- 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 --- 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 --- 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 --- 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)))))) -- 2.20.1