# 02110-1301, USA.
MIT_SCHEME_EXE = mit-scheme
-EXE = '$(MIT_SCHEME_EXE)' --batch-mode
+exe = '$(MIT_SCHEME_EXE)' --batch-mode
all:
- echo '(load "compile")' | $(EXE)
+ echo '(load "compile")' | $(exe)
@if [ -s gtk-screen-unx.crf ]; then \
echo "gtk-screen-unx.crf:0: warning: non-empty"; exit 1; fi
check:
- echo '(load "check")' | $(EXE)
+ echo '(load "check")' | $(exe)
install:
- echo '(install-shim)' | $(EXE) -- *.com *.bci *.pkd make.scm
+ echo '(install-load-option "gtk-screen")' \
+ | $(exe) -- *.com *.bci *.pkd make.scm
clean distclean maintainer-clean:
rm -f *.bin *.ext *.com *.bci *.moc *.fni *.crf *.fre *.pkd
--- /dev/null
+#| -*-Scheme-*- |#
+
+;;;; Test the gtk screen.
+
+(let ((env (->environment '(runtime pathname)))
+ (dirname (directory-pathname (current-load-pathname))))
+ (set! (access library-directory-path env)
+ (cons dirname (access library-directory-path env)))
+ (set! *initial-options-file* (merge-pathnames "gtk-screen-optiondb" dirname)))
+
+(load-option 'GTK-SCREEN)
+(if (gtk-thread-running?)
+ (load "gtk-screen-check"))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 2012, 2013 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 Gtk Screen
+
+(let ((dirname (directory-pathname (current-load-pathname)))
+ (ffi (->environment '(runtime ffi))))
+ (let ((registered-callback-count (access registered-callback-count ffi))
+ (malloced-aliens (named-lambda (malloced-aliens)
+ (access malloced-aliens ffi))))
+
+ (define (run-test name thunk)
+ (let ((condition (ignore-errors thunk)))
+ (cond ((eq? condition #t)
+ (for-each display (list "; Test "name" succeeded.\n")))
+ ((condition? condition)
+ (for-each display (list "; Test "name" failed with error:\n"))
+ (write-condition-report condition (current-output-port))
+ (newline))
+ (else
+ (for-each display (list "; Test "name" returned "condition
+ ".\n"))))))
+
+ (define (assert = obj1 obj2 form)
+ (if (not (= obj1 obj2))
+ (error "Assertion failed:" form))
+ #t)
+
+ (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))))
+
+ (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))))))))
+
+ (run-test 'gtk-screens
+ (lambda ()
+ (with-gc-notification! #t await-closed-windows)
+ (gc-flip)))
+
+ (run-test 'gtk-screens.callbacks
+ (lambda ()
+ (assert = (car (registered-callback-count))
+ 0
+ '(REGISTERED-CALLBACK-COUNT))))
+
+ (run-test 'gtk-screens.mallocs
+ (lambda ()
+ (assert = (length (malloced-aliens))
+ 0
+ '(LENGTH MALLOCED-ALIENS))))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff