From 028c0f5c954176a5baf98644db6c5f3ec7d0aa58 Mon Sep 17 00:00:00 2001
From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Sun, 3 Nov 2013 16:44:59 -0700
Subject: [PATCH] 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.
---
 src/gl/Makefile.in |  2 +-
 src/gl/check.scm   | 38 ++++++++++++++++++++++++++++++++------
 2 files changed, 33 insertions(+), 7 deletions(-)

diff --git a/src/gl/Makefile.in b/src/gl/Makefile.in
index c547a6b61..d288f26df 100644
--- 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 c1b8470a9..ff67f2525 100644
--- 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
-- 
2.25.1