add high-level interfaces to glut callback registration funcs

* figl/glut/types.scm (define-ephemeral-callback-pointer-type)
  (define-sticky-callback-pointer-type): Provide a way to protect
  procedures passed into GLUT from being GC'd.  Change the definitions
  of the pointer types to use these new helpers.

* figl/glut/low-level.scm: Use the pointer types defined in (figl glut
  types).

* figl/glut.scm: Add exports for the callback registration functions.

* examples/glut/demo.scm: Use set-display-callback.  Now the demo uses
  no low-level GLUT interfaces.

diff --git a/examples/glut/demo.scm b/examples/glut/demo.scm
index 064d8d6..68fae66 100644 (file)
--- a/examples/glut/demo.scm
+++ b/examples/glut/demo.scm
@@ -1,8 +1,7 @@
 #!/usr/bin/env guile
 !#
 
-(use-modules (figl glut low-level)
-             (figl glut)
+(use-modules (figl glut)
              (figl gl)
              (system foreign))
 
@@ -21,5 +20,5 @@
 
 (define main-window (make-window "glut"))
 
-(glutDisplayFunc (procedure->pointer void render-scene (list)))
+(set-display-callback render-scene)
 (glut-main-loop)

diff --git a/figl/glut.scm b/figl/glut.scm
index d3f7caf..683ee6c 100644 (file)
--- a/figl/glut.scm
+++ b/figl/glut.scm
@@ -248,6 +248,32 @@
            (%glutPushWindow . push-window))
 
 \f
+;;;
+;;; 7 Callback Registration
+;;;
+
+(re-export (%glutDisplayFunc . set-display-callback)
+           (%glutOverlayDisplayFunc . set-overlay-display-callback)
+           (%glutReshapeFunc . set-reshape-callback)
+           (%glutKeyboardFunc . set-keyboard-callback)
+           (%glutMouseFunc . set-mouse-callback)
+           (%glutMotionFunc . set-motion-callback)
+           (%glutPassiveMotionFunc . set-passive-motion-callback)
+           (%glutVisibilityFunc . set-visibility-callback)
+           (%glutEntryFunc . set-entry-callback)
+           (%glutSpecialFunc . set-special-callback)
+           (%glutSpaceballMotionFunc . set-spaceball-motion-callback)
+           (%glutSpaceballRotateFunc . set-spaceball-rotate-callback)
+           (%glutSpaceballButtonFunc . set-spaceball-button-callback)
+           (%glutButtonBoxFunc . set-button-box-callback)
+           (%glutDialsFunc . set-dials-callback)
+           (%glutTabletMotionFunc . set-tablet-motion-callback)
+           (%glutTabletButtonFunc . set-tablet-button-callback)
+           (%glutMenuStatusFunc . set-menu-status-callback)
+           (%glutIdleFunc . set-idle-callback)
+           (%glutTimerFunc . add-timer-callback))
+
+\f
 ;;;
 ;;; 9 State Retrieval
 ;;;

diff --git a/figl/glut/low-level.scm b/figl/glut/low-level.scm
index 2f9a855..2738625 100644 (file)
--- a/figl/glut/low-level.scm
+++ b/figl/glut/low-level.scm
@@ -345,84 +345,84 @@
 ;;;
 
 (define-glut-procedure
-  (glutDisplayFunc (func void-*) -> void)
+  (glutDisplayFunc (func display-callback-*) -> void)
   #f)
 
 (define-glut-procedure
-  (glutOverlayDisplayFunc (func void-*) -> void)
+  (glutOverlayDisplayFunc (func overlay-display-callback-*) -> void)
   #f)
 
 (define-glut-procedure
-  (glutReshapeFunc (func void-*) -> void)
+  (glutReshapeFunc (func reshape-callback-*) -> void)
   #f)
 
 (define-glut-procedure
-  (glutKeyboardFunc (func void-*) -> void)
+  (glutKeyboardFunc (func keyboard-callback-*) -> void)
   #f)
 
 (define-glut-procedure
-  (glutMouseFunc (func void-*) -> void)
+  (glutMouseFunc (func mouse-callback-*) -> void)
   #f)
 
 (define-glut-procedure
-  (glutMotionFunc (func void-*) -> void)
+  (glutMotionFunc (func motion-callback-*) -> void)
   #f)
 
 (define-glut-procedure
-  (glutPassiveMotionFunc (func void-*) -> void)
+  (glutPassiveMotionFunc (func passive-motion-callback-*) -> void)
   #f)
 
 (define-glut-procedure
-  (glutVisibilityFunc (func void-*) -> void)
+  (glutVisibilityFunc (func visibility-callback-*) -> void)
   #f)
 
 (define-glut-procedure
-  (glutEntryFunc (func void-*) -> void)
+  (glutEntryFunc (func entry-callback-*) -> void)
   #f)
 
 (define-glut-procedure
-  (glutSpecialFunc (func void-*) -> void)
+  (glutSpecialFunc (func special-callback-*) -> void)
   #f)
 
 (define-glut-procedure
-  (glutSpaceballMotionFunc (func void-*) -> void)
+  (glutSpaceballMotionFunc (func spaceball-motion-callback-*) -> void)
   #f)
 
 (define-glut-procedure
-  (glutSpaceballRotateFunc (func void-*) -> void)
+  (glutSpaceballRotateFunc (func spaceball-rotate-callback-*) -> void)
   #f)
 
 (define-glut-procedure
-  (glutSpaceballButtonFunc (func void-*) -> void)
+  (glutSpaceballButtonFunc (func spaceball-button-callback-*) -> void)
   #f)
 
 (define-glut-procedure
-  (glutButtonBoxFunc (func void-*) -> void)
+  (glutButtonBoxFunc (func button-box-callback-*) -> void)
   #f)
 
 (define-glut-procedure
-  (glutDialsFunc (func void-*) -> void)
+  (glutDialsFunc (func dials-callback-*) -> void)
   #f)
 
 (define-glut-procedure
-  (glutTabletMotionFunc (func void-*) -> void)
+  (glutTabletMotionFunc (func tablet-motion-callback-*) -> void)
   #f)
 
 (define-glut-procedure
-  (glutTabletButtonFunc (func void-*) -> void)
+  (glutTabletButtonFunc (func tablet-button-callback-*) -> void)
   #f)
 
 (define-glut-procedure
-  (glutMenuStatusFunc (func void-*) -> void)
+  (glutMenuStatusFunc (func menu-status-callback-*) -> void)
   #f)
 
 (define-glut-procedure
-  (glutIdleFunc (func void-*) -> void)
+  (glutIdleFunc (func idle-callback-*) -> void)
   #f)
 
 (define-glut-procedure
   (glutTimerFunc (msecs unsigned-int)
-                 (func void-*)
+                 (func timer-callback-*)
                  (value int)
                  ->
                  void)

diff --git a/figl/glut/types.scm b/figl/glut/types.scm
index da1fb25..91e0723 100644 (file)
--- a/figl/glut/types.scm
+++ b/figl/glut/types.scm
@@ -66,64 +66,96 @@
 (define-simple-foreign-type int-* '*)
 (define-simple-foreign-type char-** '*)
 
-(define (coerce-callback-pointer x return-type arg-types)
+;; Callbacks are either "ephemeral" or "sticky".  Ephemeral callbacks
+;; are only called once, and are protected between the time they are
+;; wrapped and the time they are called.  Sticky callbacks can be called
+;; multiple times, and are protected for all time.  Perhaps we should
+;; allow sticky callbacks to be unprotected at some time, but it
+;; probably doesn't matter.
+
+(define *gc-protected* '())
+
+(define (gc-protect! proc)
+  (set! *gc-protected* (cons proc *gc-protected*)))
+
+(define (gc-unprotect! proc)
+  (set! *gc-protected* (delq! proc *gc-protected*)))
+
+(define (coerce-callback-pointer/ephemeral x return-type arg-types)
+  (cond
+   ((ffi:pointer? x)
+    x)
+   ((procedure? x)
+    (letrec ((wrapper (lambda args
+                        (gc-unprotect! wrapper)
+                        (apply x args))))
+      (gc-protect! wrapper)
+      (ffi:procedure->pointer return-type wrapper arg-types)))
+   (else
+    (error "unhandled callback-pointer type" x))))
+
+(define (coerce-callback-pointer/sticky x return-type arg-types)
   (cond
    ((ffi:pointer? x)
     x)
    ((procedure? x)
+    (gc-protect! x)
     (ffi:procedure->pointer return-type x arg-types))
    (else
     (error "unhandled callback-pointer type" x))))
 
-(define-syntax define-callback-pointer-type
+(define-syntax define-ephemeral-callback-pointer-type
   (syntax-rules (->)
     ((_ name ((pname ptype) ... -> type))
      (define-foreign-type name '*
-       (cute coerce-callback-pointer <> (type) (list (ptype) ...))
+       (cute coerce-callback-pointer/ephemeral <> (type) (list (ptype) ...))
        (lambda (x) x)))))
 
-;; TODO: These callback-pointer types are not used at, as it is not
-;; clear how to efficiently keep the pointers alive.  Defined now
-;; anyway as a stub, and users can access them if they keep the
-;; pointer alive themselves.
+(define-syntax define-sticky-callback-pointer-type
+  (syntax-rules (->)
+    ((_ name ((pname ptype) ... -> type))
+     (define-foreign-type name '*
+       (cute coerce-callback-pointer/sticky <> (type) (list (ptype) ...))
+       (lambda (x) x)))))
 
-(define-callback-pointer-type display-callback-*
+(define-sticky-callback-pointer-type display-callback-*
   (-> void))
-(define-callback-pointer-type overlay-display-callback-*
+(define-sticky-callback-pointer-type overlay-display-callback-*
   (-> void))
-(define-callback-pointer-type reshape-callback-*
+(define-sticky-callback-pointer-type reshape-callback-*
   ((width int) (height int) -> void))
-(define-callback-pointer-type keyboard-callback-*
+(define-sticky-callback-pointer-type keyboard-callback-*
   ((key unsigned-char) (x int) (y int) -> void))
-(define-callback-pointer-type mouse-callback-*
+(define-sticky-callback-pointer-type mouse-callback-*
   ((button int) (state int) (x int) (y int) -> void))
-(define-callback-pointer-type motion-callback-*
+(define-sticky-callback-pointer-type motion-callback-*
   ((x int) (y int) -> void))
-(define-callback-pointer-type passive-motion-callback-*
+(define-sticky-callback-pointer-type passive-motion-callback-*
   ((x int) (y int) -> void))
-(define-callback-pointer-type visibility-callback-*
+(define-sticky-callback-pointer-type visibility-callback-*
   ((state int) -> void))
-(define-callback-pointer-type entry-callback-*
+(define-sticky-callback-pointer-type entry-callback-*
   ((state int) -> void))
-(define-callback-pointer-type special-callback-*
+(define-sticky-callback-pointer-type special-callback-*
   ((key int) (x int) (y int) -> void))
-(define-callback-pointer-type spaceball-motion-callback-*
+(define-sticky-callback-pointer-type spaceball-motion-callback-*
   ((x int) (y int) (z int) -> void))
-(define-callback-pointer-type spaceball-rotate-callback-*
+(define-sticky-callback-pointer-type spaceball-rotate-callback-*
   ((x int) (y int) (z int) -> void))
-(define-callback-pointer-type spaceball-button-callback-*
+(define-sticky-callback-pointer-type spaceball-button-callback-*
   ((button int) (state int) -> void))
-(define-callback-pointer-type button-box-callback-*
+(define-sticky-callback-pointer-type button-box-callback-*
   ((button int) (state int) -> void))
-(define-callback-pointer-type dials-callback-*
+(define-sticky-callback-pointer-type dials-callback-*
   ((dial int) (value int) -> void))
-(define-callback-pointer-type tablet-motion-callback-*
+(define-sticky-callback-pointer-type tablet-motion-callback-*
   ((x int) (y int) -> void))
-(define-callback-pointer-type tablet-button-callback-*
+(define-sticky-callback-pointer-type tablet-button-callback-*
   ((button int) (state int) (x int) (y int) -> void))
-(define-callback-pointer-type menu-status-callback-*
+(define-sticky-callback-pointer-type menu-status-callback-*
   ((status int) (x int) (y int) -> void))
-(define-callback-pointer-type idle-callback-*
+(define-sticky-callback-pointer-type idle-callback-*
   (-> void))
-(define-callback-pointer-type timer-callback-*
+
+(define-ephemeral-callback-pointer-type timer-callback-*
   ((value int) -> void))