From: Matt Birkholz Date: Tue, 17 Sep 2013 00:30:20 +0000 (-0700) Subject: gtk-screen: Implement make target "check". X-Git-Tag: mit-scheme-pucked-9.2.12~366^2~25 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c24bd49ffe7cfd10f414eb359cb191a725aa683d;p=mit-scheme.git gtk-screen: Implement make target "check". --- diff --git a/src/TAGS b/src/TAGS index bc04cc883..e0668593b 100644 --- a/src/TAGS +++ b/src/TAGS @@ -15,9 +15,4 @@ cref/TAGS,include rcs/TAGS,include -<<<<<<< HEAD -imail/TAGS,include - -======= ->>>>>>> e15962eff9573c3e57401773ef469d514789414e ffi/TAGS,include diff --git a/src/gtk-screen/Makefile b/src/gtk-screen/Makefile index fc04e30bf..aa601261e 100644 --- a/src/gtk-screen/Makefile +++ b/src/gtk-screen/Makefile @@ -18,18 +18,19 @@ # 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 diff --git a/src/gtk-screen/check.scm b/src/gtk-screen/check.scm new file mode 100644 index 000000000..d93183a4c --- /dev/null +++ b/src/gtk-screen/check.scm @@ -0,0 +1,13 @@ +#| -*-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 diff --git a/src/gtk-screen/gtk-screen-check.scm b/src/gtk-screen/gtk-screen-check.scm new file mode 100644 index 000000000..2b4b52d69 --- /dev/null +++ b/src/gtk-screen/gtk-screen-check.scm @@ -0,0 +1,91 @@ +#| -*-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 diff --git a/src/gtk-screen/gtk-screen-optiondb.scm b/src/gtk-screen/gtk-screen-optiondb.scm new file mode 100644 index 000000000..0b31b294b --- /dev/null +++ b/src/gtk-screen/gtk-screen-optiondb.scm @@ -0,0 +1,15 @@ +#| -*-Scheme-*- |# + +;;;; Test optiondb, includes the installed system's optiondb. + +(define-load-option 'GTK-SCREEN + (let ((pathname + (merge-pathnames "make" + (directory-pathname (current-load-pathname))))) + (named-lambda (gtk-screen-option-loader) + (load pathname)))) + +(further-load-options + (merge-pathnames "optiondb" + (last (access library-directory-path + (->environment '(runtime pathname)))))) \ No newline at end of file diff --git a/src/gtk-screen/gtk-screen.pkg b/src/gtk-screen/gtk-screen.pkg index f9be66f5a..6d66e3623 100644 --- a/src/gtk-screen/gtk-screen.pkg +++ b/src/gtk-screen/gtk-screen.pkg @@ -23,10 +23,10 @@ USA. ;;;; Gtk-Screen System Packaging -(global-definitions "../runtime/runtime") -(global-definitions "../sos/sos") -(global-definitions "../gtk/gtk") -(global-definitions "../edwin/edwin") +(global-definitions runtime/) +(global-definitions sos/) +(global-definitions gtk/) +(global-definitions edwin/) (define-package (edwin screen gtk-screen) (files "gtk-screen" "gtk-faces")