--- /dev/null
- EXE = '$(MIT_SCHEME_EXE)' --batch-mode
+# 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
- echo '(load "compile")' | $(EXE)
++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 "check")' | $(EXE)
- echo '(load "check-doc")' | $(EXE)
++ echo '(load "compile")' | $(exe)
+ @if [ -s gtk-unx.crf ]; then \
+ echo "gtk-unx.crf:0: warning: non-empty"; exit 1; fi
+
+check:
- | $(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>"
++ echo '(load "check")' | $(exe)
++ echo '(load "check-doc")' | $(exe)
+
+install:
+ echo '(install-shim "gtk")' \
- echo "(link-shim)" | $(EXE) -- $(LDFLAGS) -o $@ $^ $(LIBS) \
++ | $(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 "(compile-shim)" | $(EXE) -- `pkg-config --cflags gtk+-3.0` -c $<
++ 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) -- $(CPPFLAGS) $(CFLAGS) \
++ echo "(compile-shim)" | $(exe) -- `pkg-config --cflags gtk+-3.0` -c $<
+
+gtk-shim.o: gtk-shim.c gtk-shim.h
- echo '(generate-shim "gtk" "#include \"gtk-shim.h\"")' | $(EXE)
++ 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 '(sf "gtk-const")' | $(EXE)
++ echo '(generate-shim "gtk" "#include \"gtk-shim.h\"")' | $(exe)
+
+gtk-const.bin: gtk-const.scm
++ 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
--- /dev/null
- 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.
+The gtk wrapper.
+
+To build:
+
+ ./configure [--with-gtk=directory]...
+ make all check install
+
+The install target copies a shared library shim and compiled Scheme
- To load via load-option, install the following in your optiondb.scm:
-
- (define-load-option 'GTK
- (guarded-system-loader '(gtk) "gtk"))
++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 use: (load-option 'GTK) and import the bindings you want. Only a
++few bindings are exported to the global environment.
--- /dev/null
- (display "; libpath: ")
- (display (access library-directory-path (->environment '(runtime pathname))))
- (newline)
- (display "; gtk-thread: ")
- (display (access gtk-thread (->environment '(gtk thread))))
- (newline)
+#| -*-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))))
+ (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)))))))
projects / mit-scheme.git / commitdiff