gl: make check

Set library-directory-path; fluid-binding does not work so well when
glx-widget key-press handlers and destroy callbacks run in gtk-thread.
Join with animation thread to ensure gc-flip will clean up everything.
Check that everything is cleaned up.

diff --git a/src/gl/Makefile.in b/src/gl/Makefile.in
index c547a6b6164dfcf246aa97520fe5c752d2c28cbf..d288f26df2307a7deb4e83afb35314c93878ae4b 100644 (file)
--- a/src/gl/Makefile.in
+++ b/src/gl/Makefile.in
@@ -30,7 +30,7 @@ all: gl-shim.so gl-types.bin gl-const.bin
        @if [ -s gl-unx.crf ]; then \
             echo "gl-unx.crf:0: warning: non-empty"; exit 1; fi
 
-check: glxgears
+check:
        echo '(load "check")' | $(exe)
 
 glxgears: glxgears-shim.so glxgears-types.bin glxgears-const.bin

diff --git a/src/gl/check.scm b/src/gl/check.scm
index c1b8470a9aa4c09d6050b41ba6d228d136f3704f..ff67f2525322acbef03a98b1a08401b4fb62b8b9 100644 (file)
--- a/src/gl/check.scm
+++ b/src/gl/check.scm
@@ -2,9 +2,35 @@
 
 ;;;; Run the GLXGears demo.
 
-(load "make")
-(with-system-library-directories
- '("./")
- (lambda ()
-   (load-package-set "glxgears")
-   ((access main (->environment '(gl glxgears))))))
\ No newline at end of file
+(load-option 'GTK)
+
+(if (gtk-thread-running?)
+    (begin
+      (let ((env (->environment '(runtime pathname))))
+       (set! (access library-directory-path env)
+             (cons (merge-pathnames "./")
+                   (access library-directory-path env))))
+      (load "make")
+      (let* ((widget (make-glxgears-demo))
+            (thread ((access glxgears-demo-animation-thread
+                             (->environment '(gl glxgears)))
+                     widget)))
+       (let ((gtk (->environment '(gtk gtk-widget))))
+         (let wait ()
+           (if (not (null? (access toplevel-windows gtk)))
+               (begin
+                 (sleep-current-thread 1000)
+                 (wait)))))
+       (join-thread thread (lambda (thread* value)
+                             (lambda ()
+                               (display "; glxgears: joined\n")
+                               (if (not (eq? thread* thread))
+                                   (error "What?!"))
+                               value))))
+      (gc-flip)
+      (let ((ffi (->environment '(runtime ffi))))
+       (if (not (= 0 (length (access malloced-aliens ffi))))
+           (warn "Test gl-demo.mallocs failed.\n"))
+       (if (not (= 0 (car ((access registered-callback-count ffi)))))
+           (warn "; Test gl-demo.callbacks failed.\n"))))
+    (warn "Could not test the GL subsystem without a DISPLAY."))
\ No newline at end of file