gtk: Run gtk/test-gtk.scm which now punts if DISPLAY is not set.

diff --git a/tests/check.scm b/tests/check.scm
index 7d436ed577e1b5eda88f789c24562c3933983663..74c71cf23cdb12978145c4423efec632a11d1793 100644 (file)
--- a/tests/check.scm
+++ b/tests/check.scm
@@ -47,11 +47,11 @@ USA.
     "runtime/test-floenv"
     "runtime/test-hash-table"
     "runtime/test-integer-bits"
-    "runtime/test-process"
+;    "runtime/test-process"
     "runtime/test-regsexp"
     ("runtime/test-wttree" (runtime wt-tree))
-    "ffi/test-ffi"
-    ;;"gtk/test-gtk"                   ;Requires a DISPLAY at the mo'.
+    "ffi/test-ffi.scm"
+    "gtk/test-gtk.scm"
     ))
 
 (with-working-directory-pathname

diff --git a/tests/gtk/test-gfile-operations.scm b/tests/gtk/gtk-tests.scm
similarity index 60%
rename from tests/gtk/test-gfile-operations.scm
rename to tests/gtk/gtk-tests.scm
index ccf79e3199242512d03fb30e04df1d3765847299..b85aa6c80d0d59d7a5fe628c68f3090d9a4c7a75 100644 (file)
--- a/tests/gtk/test-gfile-operations.scm
+++ b/tests/gtk/gtk-tests.scm
@@ -1,6 +1,9 @@
 #| -*-Scheme-*-
 
-Copyright (C) 2011  Matthew Birkholz
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+    2006, 2007, 2008, 2009, 2010, 2011, 2012 Massachusetts Institute
+    of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -21,8 +24,29 @@ USA.
 
 |#
 
-;;;; Test gfile operations.
+;;;; Test procedures for the gtks.
 \f
+;;; GIO tests.
+
+(define test-copy-integrity
+  (let ((cwd (directory-pathname (current-load-pathname))))
+    (named-lambda (test-copy-integrity)
+      (with-working-directory-pathname cwd
+       (lambda ()
+         (let ((file1 "../../src/README.txt")
+               (file2 "test-copy-1.txt"))
+           (gcp file1 file2)
+           (assert-equal (md5-file file2) (md5-file file1))))))))
+
+(define test-child-enumeration
+  (let ((cwd (directory-pathname (current-load-pathname))))
+    (named-lambda (test-child-enumeration)
+      (with-working-directory-pathname cwd
+       (lambda ()
+         (let ((native (sort (ls "../runtime/") string<?))
+               (gio (sort (gls "../runtime/") string<?)))
+           (assert-equal gio native)))))))
+
 (define (gcp src dst)
   (let ((gsrc (open-input-gfile src))
        (gdst (open-output-gfile dst)))
@@ -64,4 +88,19 @@ USA.
   (sort (gdirectory-read uri) string<?))
 
 (define ->simple-namestring
-  (access ->simple-namestring (->environment '(gtk gio))))
\ No newline at end of file
+  (access ->simple-namestring (->environment '(gtk gio))))
+\f
+;;; Gtk tests.
+
+(define (await-closed-demos)
+  (gtk-time-slice-window! #t)
+  (hello)
+  (make-gtk-event-viewer-demo)
+  (make-fix-layout-demo)
+  (make-pole-zero)
+  (let loop ()
+    (if (not (null? (access toplevel-windows
+                           (->environment '(gtk gtk-object)))))
+       (begin
+         (sleep-current-thread 1000)
+         (loop)))))
\ No newline at end of file

diff --git a/tests/gtk/test-gtk.scm b/tests/gtk/test-gtk.scm
index ac155776fa5bfb8eea43f8754c522abe6a3b8b33..bd8f9fb43f5026d10709b71fc03319578015664f 100644 (file)
--- a/tests/gtk/test-gtk.scm
+++ b/tests/gtk/test-gtk.scm
@@ -1,37 +1,64 @@
 ;;;-*-Scheme-*-
 
-(load-option 'Gtk)
+(define gcp)
+(define gls)
+(define ls)
+(define await-closed-demos)
+(define registered-callback-count)
+(define malloced-aliens)
+(define (main)
+  (let ((new (extend-top-level-environment (->environment '(gtk))))
+       (ffi (->environment '(runtime ffi))))
+    (with-working-directory-pathname "gtk/"
+      (lambda ()
+       (compile-file "gtk-tests" '() new)
+       (load "gtk-tests" new)))
+    (load "../src/gtk/hello.scm" new)
+    (set! gcp (access gcp new))
+    (set! gls (access gls new))
+    (set! ls (access ls new))
+    (set! await-closed-demos (access await-closed-demos new))
+    (set! registered-callback-count
+         (access registered-callback-count ffi))
+    (set! malloced-aliens (access malloced-aliens ffi)))
 
-(with-working-directory-pathname (directory-pathname (current-load-pathname))
-  (lambda ()
-    (let ((env (->environment '(gtk))))
-      (compile-file "test-gfile-operations" '() env)
-      (load "test-gfile-operations" env))))
+  (define-test 'gio-copy
+    (let ((cwd (directory-pathname (current-load-pathname))))
+      (named-lambda (gio-copy-test)
+       (with-working-directory-pathname cwd
+         (lambda ()
+           (let ((file1 "../../src/README.txt")
+                 (file2 "test-copy-1.txt"))
+             (gcp file1 file2)
+             (assert-equal (md5-file file2) (md5-file file1)
+                           'EXPRESSION (list 'GCP file1 file2))))))))
 
-(define test-copy-integrity
-  (let ((cwd (directory-pathname (current-load-pathname))))
-    (named-lambda (test-copy-integrity)
-      (with-working-directory-pathname cwd
-       (lambda ()
-         (let ((file1 "../../src/README.txt")
-               (file2 "test-copy-1.txt"))
-           (gcp file1 file2)
-           (assert-equal (md5-file file2) (md5-file file1))))))))
+  (define-test 'gio-list
+    (let ((cwd (directory-pathname (current-load-pathname))))
+      (named-lambda (gio-list-test)
+       (with-working-directory-pathname cwd
+         (lambda ()
+           (let ((native (sort (ls "../runtime/") string<?))
+                 (gio (sort (gls "../runtime/") string<?)))
+             (assert-equal gio native
+                           'EXPRESSION '(GLS "../runtime/"))))))))
 
-(define gcp (access gcp (->environment '(gtk))))
+  (define-test 'gtk-demos
+    (lambda ()
+      (await-closed-demos)
+      (gc-flip)))
 
-(define-test 'gio-copy test-copy-integrity)
+  (define-test 'gtk-demos.callbacks
+    (lambda ()
+      (assert-= (car (registered-callback-count))
+               0
+               'EXPRESSION '(REGISTERED-CALLBACK-COUNT))))
 
-(define test-child-enumeration
-  (let ((cwd (directory-pathname (current-load-pathname))))
-    (named-lambda (test-child-enumeration)
-      (with-working-directory-pathname cwd
-       (lambda ()
-         (let ((native (sort (ls "../runtime/") string<?))
-               (gio (sort (gls "../runtime/") string<?)))
-           (assert-equal gio native)))))))
+  (define-test 'gtk-demos.mallocs
+    (lambda ()
+      (assert-= (length malloced-aliens)
+               0
+               'EXPRESSION '(LENGTH MALLOCED-ALIENS)))))
 
-(define gls (access gls (->environment '(gtk))))
-(define ls (access ls (->environment '(gtk))))
-
-(define-test 'gio-list test-child-enumeration)
\ No newline at end of file
+(if (not (warn-errors? (lambda () (load-option 'gtk))))
+    (main))
\ No newline at end of file