From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Sun, 15 Sep 2013 03:55:17 +0000 (-0700)
Subject: Merge branch 'master' into Gtk.
X-Git-Tag: mit-scheme-pucked-9.2.12~473
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c771952db87fc93fcae52f92c811f57ec108e9e3;p=mit-scheme.git

Merge branch 'master' into Gtk.

Use install-load-option in Makefile.in.
---

c771952db87fc93fcae52f92c811f57ec108e9e3
diff --cc src/gtk/Makefile.in
index 554634811,000000000..d5585706d
mode 100644,000000..100644
--- a/src/gtk/Makefile.in
+++ b/src/gtk/Makefile.in
@@@ -1,98 -1,0 +1,96 @@@
 +# Copyright (C) 2011, 2012, 2013 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.
 +
 +MIT_SCHEME_EXE = mit-scheme
- EXE = '$(MIT_SCHEME_EXE)' --batch-mode
++exe = '$(MIT_SCHEME_EXE)' --batch-mode
 +
 +CFLAGS = @CFLAGS@
 +CPPFLAGS = @CPPFLAGS@
 +LDFLAGS = @LDFLAGS@
 +LIBS = @LIBS@
 +
 +all: gtk-shim.so gtk-types.bin gtk-const.bin
- 	echo '(load "compile")' | $(EXE)
++	echo '(load "compile")' | $(exe)
 +	@if [ -s gtk-unx.crf ]; then \
 +	     echo "gtk-unx.crf:0: warning: non-empty"; exit 1; fi
 +
 +check:
- 	echo '(load "check")' | $(EXE)
- 	echo '(load "check-doc")' | $(EXE)
++	echo '(load "check")' | $(exe)
++	echo '(load "check-doc")' | $(exe)
 +
 +install:
 +	echo '(install-shim "gtk")' \
- 	| $(EXE) -- *.com *.bci *.pkd make.scm conses.png
- 
- #install-optiondb
- #install-manual "<li><a href=\"mit-scheme-gtk/index.html\">GTK User's Manual</a></li>"
++	| $(exe) -- *.com *.bci *.pkd make.scm conses.png
++	echo '(install-load-option "gtk")' | $(exe)
 +
 +clean:
 +	rm -f gtk-const.scm gtk-const gtk-const.c gtk-shim.c
 +	rm -f gtk-*.crf gtk-*.fre gtk-*.pkd
 +	rm -f *.o *.so *.bin *.ext *.com *.bci *.moc *.fni
 +
 +distclean: clean
 +	rm -f Makefile config.h config.log config.status
 +
 +maintainer-clean: distclean
 +	rm -f configure config.h.in
 +	rm -rf autom4te.cache
 +
 +tags:
 +	etags *.h \
 +	    `echo *.c   | sed 's/ gtk-const.c//; s/ gtk-shim.c//'` \
 +	    `echo *.scm | sed 's/ gtk-const.scm//'` \
 +	    -r '/^([^iI].*/' Includes/*.cdecl
 +
 +gtk-shim.so: gtk-shim.o gtkpanedview.o gtkscrolledview.o scmwidget.o gtkio.o
- 	echo "(link-shim)" | $(EXE) -- $(LDFLAGS) -o $@ $^ $(LIBS) \
++	echo "(link-shim)" | $(exe) -- $(LDFLAGS) -o $@ $^ $(LIBS) \
 +			`pkg-config --libs gtk+-3.0 gthread-2.0`
 +
 +gtkscrolledview.o: gtkscrolledview.c gtkscrolledview.h
- 	echo "(compile-shim)" | $(EXE) -- `pkg-config --cflags gtk+-3.0` -c $<
++	echo "(compile-shim)" | $(exe) -- `pkg-config --cflags gtk+-3.0` -c $<
 +
 +gtkpanedview.o: gtkpanedview.c gtkpanedview.h
- 	echo "(compile-shim)" | $(EXE) -- `pkg-config --cflags gtk+-3.0` -c $<
++	echo "(compile-shim)" | $(exe) -- `pkg-config --cflags gtk+-3.0` -c $<
 +
 +scmwidget.o: scmwidget.c scmwidget.h
- 	echo "(compile-shim)" | $(EXE) -- `pkg-config --cflags gtk+-3.0` -c $<
++	echo "(compile-shim)" | $(exe) -- `pkg-config --cflags gtk+-3.0` -c $<
 +
 +gtkio.o: gtkio.c
- 	echo "(compile-shim)" | $(EXE) -- `pkg-config --cflags gtk+-3.0` -c $<
++	echo "(compile-shim)" | $(exe) -- `pkg-config --cflags gtk+-3.0` -c $<
 +
 +gtk-shim.o: gtk-shim.c gtk-shim.h
- 	echo "(compile-shim)" | $(EXE) -- $(CPPFLAGS) $(CFLAGS) \
++	echo "(compile-shim)" | $(exe) -- $(CPPFLAGS) $(CFLAGS) \
 +					`pkg-config --cflags gtk+-3.0` -c $<
 +
 +gtk-shim.c gtk-const.c gtk-types.bin: gtk-shim.h gtk.cdecl \
 +					Includes/*.cdecl Includes/*/*.cdecl
- 	echo '(generate-shim "gtk" "#include \"gtk-shim.h\"")' | $(EXE)
++	echo '(generate-shim "gtk" "#include \"gtk-shim.h\"")' | $(exe)
 +
 +gtk-const.bin: gtk-const.scm
- 	echo '(sf "gtk-const")' | $(EXE)
++	echo '(sf "gtk-const")' | $(exe)
 +
 +gtk-const.scm: gtk-const
 +	./gtk-const
 +
 +gtk-const: gtk-const.o
 +	$(CC) $(LDFLAGS) -o $@ $^ $(LIBS) `pkg-config --libs gtk+-3.0`
 +
 +gtk-const.o: gtk-const.c gtk-shim.h
 +	$(CC) $(CPPFLAGS) `pkg-config --cflags gtk+-3.0` $(CFLAGS) -c $<
 +
 +.PHONY: all check install clean distclean maintainer-clean tags
diff --cc src/gtk/README
index 2c9d66788,000000000..a8cd1d78e
mode 100644,000000..100644
--- a/src/gtk/README
+++ b/src/gtk/README
@@@ -1,16 -1,0 +1,14 @@@
 +The gtk wrapper.
 +
 +To build:
 +
 +    ./configure [--with-gtk=directory]...
 +    make all check install
 +
 +The install target copies a shared library shim and compiled Scheme
- files into the system library path.  You can override the default
- command name "mit-scheme" (and thus the system library path) by
- setting MIT_SCHEME_EXE.
++files into the system library path, and re-writes the optiondb.scm
++found there.  You can override the default command name "mit-scheme"
++(and thus the system library path) by setting MIT_SCHEME_EXE.
 +
- To load via load-option, install the following in your optiondb.scm:
- 
-     (define-load-option 'GTK
-       (guarded-system-loader '(gtk) "gtk"))
++To use: (load-option 'GTK) and import the bindings you want.  Only a
++few bindings are exported to the global environment.
diff --cc src/gtk/gtk-check.scm
index 504a0ce2c,000000000..8dffd93c4
mode 100644,000000..100644
--- a/src/gtk/gtk-check.scm
+++ b/src/gtk/gtk-check.scm
@@@ -1,102 -1,0 +1,96 @@@
 +#| -*-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 Gtks
 +
 +(let ((new (extend-top-level-environment (->environment '(gtk))))
 +      (ffi (->environment '(runtime ffi))))
-   (display "; libpath: ")
-   (display (access library-directory-path (->environment '(runtime pathname))))
-   (newline)
-   (display "; gtk-thread: ")
-   (display (access gtk-thread (->environment '(gtk thread))))
-   (newline)
 +  (load "gtk-tests" new)
 +  (load "hello" new)
 +  (let ((gcp (access gcp new))
 +	(gls (access gls new))
 +	(ls (access ls new))
 +	(await-closed-demos (access await-closed-demos new))
 +	(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)
 +
 +    (run-test
 +     'gio-copy
 +     (let ((cwd (directory-pathname (current-load-pathname))))
 +       (named-lambda (gio-copy-test)
 +	 (with-working-directory-pathname cwd
 +	   (lambda ()
 +	     (let ((file1 "../README.txt")
 +		   (file2 "test-copy-1.txt"))
 +	       (gcp file1 file2)
 +	       (assert equal? (md5-file file2) (md5-file file1)
 +		       `(GCP ,file1 ,file2))))))))
 +
 +    (run-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
 +		       '(GLS "../runtime/"))))))))
 +
 +    (run-test
 +     'gtk-demos
 +     (named-lambda (gtk-demos-test)
 +       (with-gc-notification! #t await-closed-demos)
 +       #t))
 +
 +    (gc-flip)
 +
 +    (run-test
 +     'gtk-demos.callbacks
 +     (named-lambda (gtk-demos.callbacks-test)
 +       (assert = 0 (car (registered-callback-count))
 +	       '(REGISTERED-CALLBACK-COUNT))))
 +
 +    (run-test
 +     'gtk-demos.mallocs
 +     (named-lambda (gtk-demos.mallocs-test)
 +       (assert = 0 (length (malloced-aliens))
 +	       '(LENGTH (MALLOCED-ALIENS)))))))