From d24cc2b8f241589724540cee113ec827715bde19 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Mon, 11 Feb 2013 16:00:45 +0100
Subject: [PATCH] automatic glut initialization

* figl/glut/runtime.scm (resolve): Run a hook before resolving glut
  symbols.  Remove the plural define-glut-procedures.

* figl/glut.scm: Rename glut-init to initialize-glut, and add keyword
  arguments for initial window size, position, and display mode.
  Default to (program-arguments) for args.  Make the glut-init? marker
  global, not thread-local.  Add resolve hook to initialize-glut as
  needed.

* examples/glut/demo.scm: Update.
---
 examples/glut/demo.scm |  6 ++--
 figl/glut.scm          | 69 +++++++++++++++++++++++++-----------------
 figl/glut/runtime.scm  | 18 +++++------
 3 files changed, 51 insertions(+), 42 deletions(-)

diff --git a/examples/glut/demo.scm b/examples/glut/demo.scm
index 68fae66..b92bb40 100644
--- a/examples/glut/demo.scm
+++ b/examples/glut/demo.scm
@@ -13,10 +13,8 @@
     (gl-vertex 0.0 0.5 0.0))
   (swap-buffers))
 
-(set-initial-window-size 320 200)
-(set-initial-display-mode (display-mode rgb double depth))
-
-(glut-init (program-arguments))
+(initialize-glut #:window-size '(320 . 200)
+                 #:display-mode (display-mode rgb double depth))
 
 (define main-window (make-window "glut"))
 
diff --git a/figl/glut.scm b/figl/glut.scm
index 683ee6c..153cdb9 100644
--- a/figl/glut.scm
+++ b/figl/glut.scm
@@ -23,6 +23,7 @@
 
 (define-module (figl glut)
   #:use-module (figl contrib)
+  #:use-module (figl glut runtime)
   #:use-module ((figl glut low-level) #:renamer (symbol-prefix-proc '%))
   #:use-module (figl glut enums)
   #:use-module (system foreign)
@@ -36,10 +37,13 @@
 ;;; 2 Initialization
 ;;;
 
-;; TODO: Most procedures should prevent themself from being called
-;; before glut-init.
+(re-export (%glutInitWindowPosition . set-initial-window-position)
+           (%glutInitWindowSize . set-initial-window-size)
+           (%glutInitDisplayMode . set-initial-display-mode))
+
+(define glut-init? #f)
 
-(define glut-init? (make-parameter #f))
+(define saved-c-strings '())
 
 ;; Note the use of 'saved-c-strings' to keep a reference to all of the
 ;; C string buffers that we ever pass to 'glutInit'. This is important
@@ -49,31 +53,42 @@
 ;; string buffer managed by the garbage collector, which means that
 ;; the string may be freed unless the GC can see a pointer to the
 ;; _beginning_ of the string.
-(define glut-init
-  (let ((saved-c-strings '()))
-    (lambda (args)
-      ;; Avoid calling init twice as GLUT will exit().
-      (unless (glut-init?)
-        (let* ((num-args (length args))
-               (c-strings (map string->pointer args))
-               (argcp (make-c-struct (list int)
-                                     (list num-args)))
-               (argv (make-c-struct (make-list (+ 1 num-args) '*)
-                                    (append c-strings
-                                            (list %null-pointer)))))
-          (set! saved-c-strings (append c-strings saved-c-strings))
-          (%glutInit argcp argv)
-          (glut-init? #t)
-          (let ((argc (car (parse-c-struct argcp (list int)))))
-            (map pointer->string
-                 (parse-c-struct argv
-                                 (make-list argc '*)))))))))
-
-(export glut-init)
 
-(re-export (%glutInitWindowPosition . set-initial-window-position)
-           (%glutInitWindowSize . set-initial-window-size)
-           (%glutInitDisplayMode . set-initial-display-mode))
+(define* (initialize-glut #:optional (args (program-arguments))
+                          #:key window-position window-size display-mode)
+  (when glut-init?
+    (error "GLUT already initialized"))
+
+  (when window-position
+    (%glutInitWindowPosition (car window-position) (cdr window-position)))
+
+  (when window-size
+    (%glutInitWindowSize (car window-size) (cdr window-size)))
+
+  (when display-mode
+    (%glutInitDisplayMode display-mode))
+
+  (let* ((num-args (length args))
+         (c-strings (map string->pointer args))
+         (argcp (make-c-struct (list int)
+                               (list num-args)))
+         (argv (make-c-struct (make-list (+ 1 num-args) '*)
+                              (append c-strings (list %null-pointer)))))
+    (set! saved-c-strings (append c-strings saved-c-strings))
+    (%glutInit argcp argv)
+    (set! glut-init? #t)
+    (let ((argc (car (parse-c-struct argcp (list int)))))
+      (map pointer->string
+           (parse-c-struct argv
+                           (make-list argc '*))))))
+
+(add-hook! *resolve-hook*
+           (lambda (name)
+             (unless (or glut-init? (string-prefix? "glutInit" name))
+               (initialize-glut))))
+
+(export initialize-glut)
+
 
 ;;;
 ;;; 3 Beginning Event Processing
diff --git a/figl/glut/runtime.scm b/figl/glut/runtime.scm
index 3f7d3a3..e022a68 100644
--- a/figl/glut/runtime.scm
+++ b/figl/glut/runtime.scm
@@ -25,7 +25,8 @@
   #:use-module (system foreign)
   #:use-module (figl runtime)
   #:use-module (figl gl runtime)
-  #:export (define-glut-procedure define-glut-procedures))
+  #:export (*resolve-hook*
+            define-glut-procedure))
 
 (define libglut
   (delay (dynamic-link "libglut")))
@@ -35,8 +36,12 @@
 
 (current-gl-get-dynamic-object get-libglut)
 
+(define *resolve-hook* (make-hook 1))
+
 (define (resolve name)
-  (dynamic-pointer (symbol->string name) (get-libglut)))
+  (let ((name-str (symbol->string name)))
+    (run-hook *resolve-hook* name-str)
+    (dynamic-pointer name-str (get-libglut))))
 
 (define-syntax define-glut-procedure
   (syntax-rules (->)
@@ -45,12 +50,3 @@
      (define-foreign-procedure (name (pname ptype) ... -> type)
        (resolve 'name)
        docstring))))
-
-(define-syntax define-glut-procedures
-  (syntax-rules ()
-    ((define-glut-procedures ((name prototype ...) ...)
-       docstring)
-     (begin
-       (define-glut-procedure (name prototype ...)
-         docstring)
-       ...))))
-- 
2.20.1