gtk-screen: simple test

diff --git a/tests/check.scm b/tests/check.scm
index 3d8b9a4e91a8af6c5ee9adc149ea79f261bf8774..6c7acb91f610a221b5d4dcf4cc7fd144267ef506 100644 (file)
--- 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 (file)
index 0000000..3660879
--- /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.
+\f
+(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 (file)
index 0000000..9b4a48d
--- /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