From d0158b512b0a03b6c8370a3625fdad0c0c2d6702 Mon Sep 17 00:00:00 2001
From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Tue, 29 Jan 2013 14:20:06 -0700
Subject: [PATCH] gtk-screen: simple test

---
 tests/check.scm                       |  1 +
 tests/gtk-screen/gtk-screen-tests.scm | 51 +++++++++++++++++++++
 tests/gtk-screen/test-gtk-screen.scm  | 64 +++++++++++++++++++++++++++
 3 files changed, 116 insertions(+)
 create mode 100644 tests/gtk-screen/gtk-screen-tests.scm
 create mode 100644 tests/gtk-screen/test-gtk-screen.scm

diff --git a/tests/check.scm b/tests/check.scm
index 3d8b9a4e9..6c7acb91f 100644
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -53,6 +53,7 @@ USA.
     ("runtime/test-wttree" (runtime wt-tree))
     "ffi/test-ffi.scm"
     "gtk/test-gtk.scm"
+    "gtk-screen/test-gtk-screen.scm"
     ))
 
 (with-working-directory-pathname
diff --git a/tests/gtk-screen/gtk-screen-tests.scm b/tests/gtk-screen/gtk-screen-tests.scm
new file mode 100644
index 000000000..3660879a8
--- /dev/null
+++ b/tests/gtk-screen/gtk-screen-tests.scm
@@ -0,0 +1,51 @@
+#| -*-Scheme-*-
+
+Copyright (C) 2010, 2011, 2012  Matthew Birkholz
+
+This file is part of an extension to MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Test procedure for the gtk-screen.
+
+(define (note* . args)
+  (with-notification
+   (lambda (port)
+     (for-each (lambda (o) (display o port)) args))
+   #f))
+
+(define (spawn-edit)
+  (call-with-current-continuation
+   (lambda (continue)
+     (detach-thread
+      (create-thread continue
+		     (lambda ()
+		       (let ((self (current-thread)))
+			 (note* "Edwin thread: "self)
+			 (edit)
+			 (note* "Edwin thread "self" finished.")
+			 (stop-current-thread))))))))
+
+(define (await-closed-windows)
+  (gtk-time-slice-window! #t)
+  (spawn-edit)
+  (let loop ()
+    (sleep-current-thread 1000)
+    (if (not (null? (access toplevel-windows
+			    (->environment '(gtk gtk-widget)))))
+	(loop))))
\ No newline at end of file
diff --git a/tests/gtk-screen/test-gtk-screen.scm b/tests/gtk-screen/test-gtk-screen.scm
new file mode 100644
index 000000000..9b4a48dd0
--- /dev/null
+++ b/tests/gtk-screen/test-gtk-screen.scm
@@ -0,0 +1,64 @@
+#| -*-Scheme-*-
+
+Copyright (C) 2012  Matthew Birkholz
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Test the Gtks
+
+(define gcp)
+(define gls)
+(define ls)
+(define await-closed-windows)
+(define registered-callback-count)
+(define maliens)
+(define (main)
+  (let ((new (extend-top-level-environment
+	      (->environment '(edwin screen gtk-screen))))
+	(ffi (->environment '(runtime ffi))))
+    (with-working-directory-pathname "gtk-screen/"
+      (lambda ()
+	(compile-file "gtk-screen-tests" '() new)
+	(load "gtk-screen-tests" new)))
+    (set! await-closed-windows (access await-closed-windows new))
+    (set! registered-callback-count
+	  (access registered-callback-count ffi))
+    (set! maliens (named-lambda (maliens)
+		    (access malloced-aliens ffi))))
+
+  (define-test 'gtk-screens
+    (lambda ()
+      (with-gc-notification! #t await-closed-windows)
+      (gc-flip)))
+
+  (define-test 'gtk-screens.callbacks
+    (lambda ()
+      (assert-= (car (registered-callback-count))
+		0
+		'EXPRESSION '(REGISTERED-CALLBACK-COUNT))))
+
+  (define-test 'gtk-screens.mallocs
+    (lambda ()
+      (assert-= (length (maliens))
+		0
+		'EXPRESSION '(LENGTH MALLOCED-ALIENS)))))
+
+(if (not (warn-errors? (lambda () (load-option 'gtk-screen))))
+    (main))
\ No newline at end of file
-- 
2.25.1