From: Matt Birkholz Date: Wed, 11 Sep 2013 00:03:46 +0000 (-0700) Subject: gtk: A separately buildable FFI wrapper. X-Git-Tag: mit-scheme-pucked-9.2.12~478 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c8856d333e2d36c2bbed063a646ea01b0f4a7b7f;p=mit-scheme.git gtk: A separately buildable FFI wrapper. Remove the Gtk wrapper from the core build tree. --- diff --git a/doc/Makefile.in b/doc/Makefile.in index faaf6ec05..dca4c5204 100644 --- a/doc/Makefile.in +++ b/doc/Makefile.in @@ -65,7 +65,7 @@ pdfdir = @pdfdir@ psdir = @psdir@ INST_TARGETS = @INST_TARGETS@ -SUBDIRS = ffi gtk imail ref-manual sos user-manual +SUBDIRS = ffi imail ref-manual sos user-manual DISTCLEAN_FILES = Makefile make-common config.log config.status all: diff --git a/doc/configure.ac b/doc/configure.ac index cf0e3257b..358edff73 100644 --- a/doc/configure.ac +++ b/doc/configure.ac @@ -82,7 +82,6 @@ AC_CONFIG_FILES([ Makefile make-common ffi/Makefile - gtk/Makefile imail/Makefile ref-manual/Makefile sos/Makefile diff --git a/doc/gtk/Makefile.in b/doc/gtk/Makefile.in deleted file mode 100644 index 152a8b911..000000000 --- a/doc/gtk/Makefile.in +++ /dev/null @@ -1,12 +0,0 @@ -# doc/gtk/Makefile.in - -@SET_MAKE@ -srcdir = @srcdir@ -top_srcdir = @top_srcdir@ -VPATH = @srcdir@ - -SOURCES = gtk.texinfo -TEXINFO_ROOT = gtk -TARGET_ROOT = mit-scheme-gtk - -include $(top_srcdir)/make-common diff --git a/doc/index.html b/doc/index.html index 67ca0f7d8..a66f9d5bc 100644 --- a/doc/index.html +++ b/doc/index.html @@ -16,7 +16,6 @@ The following MIT/GNU Scheme manuals are available here:
  • SOS Reference Manual
  • IMAIL User's Manual
  • FFI User's Manual
    • -
  • GTK User's Manual
    • diff --git a/src/Makefile.in b/src/Makefile.in index ffafd55f4..8a3c5d65c 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -78,13 +78,6 @@ all: @ALL_TARGET@ check: ./microcode/scheme --library lib --batch-mode \ --load ../tests/check /dev/null; then - AC_MSG_RESULT([yes]) - with_gtk=yes - else - AC_MSG_RESULT([no Gtk 3.0... no]) - with_gtk=no - fi -fi - AC_SUBST([DEFAULT_TARGET]) AC_SUBST([ALL_TARGET]) AC_SUBST([INSTALL_COM]) @@ -217,10 +195,6 @@ win32/Makefile xdoc/Makefile xml/Makefile ]) -if test "${with_gtk}" = "yes"; then - AC_CONFIG_FILES([gtk/Makefile]) - FFIS="${FFIS} gtk" -fi AC_OUTPUT if test x"${mit_scheme_native_code}" = xc; then diff --git a/src/etc/create-makefiles.sh b/src/etc/create-makefiles.sh index 6243ada75..8fe46f1c5 100755 --- a/src/etc/create-makefiles.sh +++ b/src/etc/create-makefiles.sh @@ -47,7 +47,7 @@ run_cmd rm -f compiler/machine compiler/compiler.pkg run_cmd ln -s machines/"${MDIR}" compiler/machine run_cmd ln -s machine/compiler.pkg compiler/. -BUNDLES="6001 compiler cref edwin ffi gtk imail sf sos ssp star-parser xdoc xml" +BUNDLES="6001 compiler cref edwin ffi imail sf sos ssp star-parser xdoc xml" run_cmd ${HOST_SCHEME_EXE} --batch-mode --heap 4000 <" - exit 1 -fi - -../etc/Clean.sh "${1}" -. ../etc/functions.sh - -maybe_rm gtk-shim.c gtk-const* gtk-types* swat-pole-zero* -maybe_rm ../lib/conses.png -maybe_rm ../lib/gtk-* -# And, just because the maintainer- and c-clean targets nail these anyway: -maybe_rm scmwidget.c gtkio.c diff --git a/src/gtk/Makefile-fragment b/src/gtk/Makefile-fragment deleted file mode 100644 index 18c0092d9..000000000 --- a/src/gtk/Makefile-fragment +++ /dev/null @@ -1,117 +0,0 @@ -#-*-Makefile-*- -# gtk/Makefile-fragment -# -# Copyright (C) 2011, 2012 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. - -TARGET_DIR = $(AUXDIR)/gtk - -build: ../lib/gtk-shim.so ../lib/gtk-types.bin ../lib/gtk-const.bin \ - ../lib/conses.png swat-pole-zero.scm - cd ../ && echo '(load "etc/compile.scm")(compile-ffi "gtk")' \ - | microcode/scheme --library lib --batch-mode - @if [ -s ../gtk/gtk-unx.crf ]; then \ - echo "../gtk/gtk-unx.crf:0: warning: non-empty"; exit 1; fi - -../lib/gtk-shim.so: gtk-shim.so - $(INSTALL_DATA) gtk-shim.so $@ - -../lib/gtk-types.bin: gtk-types.bin - $(INSTALL_DATA) gtk-types.bin $@ - -../lib/gtk-const.bin: gtk-const.bin - $(INSTALL_DATA) gtk-const.bin $@ - -../lib/conses.png: conses.png - $(INSTALL_DATA) conses.png $@ - -swat-pole-zero.scm: - $(LN_S) ../swat/scheme/other/pole-zero.scm swat-pole-zero.scm - -install: - rm -rf $(DESTDIR)$(TARGET_DIR) - $(mkinstalldirs) $(DESTDIR)$(TARGET_DIR) - $(INSTALL_COM) *.com $(DESTDIR)$(TARGET_DIR)/. - $(INSTALL_DATA) *.bci $(DESTDIR)$(TARGET_DIR)/. - $(INSTALL_DATA) gtk-*.pkd $(DESTDIR)$(TARGET_DIR)/. - $(INSTALL_DATA) make.scm $(DESTDIR)$(TARGET_DIR)/. - $(INSTALL_DATA) gtk-shim.so $(DESTDIR)$(AUXDIR)/. - $(INSTALL_DATA) gtk-types.bin $(DESTDIR)$(AUXDIR)/. - $(INSTALL_DATA) gtk-const.bin $(DESTDIR)$(AUXDIR)/. - $(INSTALL_DATA) conses.png $(DESTDIR)$(AUXDIR)/. - if test `echo "(pp microcode-id/compiled-code-type)" \ - | ../microcode/scheme --library ../lib --batch-mode` = "c"; \ - then $(MAKE) install-liarc-bundle; fi - -gtk-shim.so: gtk-shim.o gtkpanedview.o gtkscrolledview.o scmwidget.o \ - gtkio.o $(SHIM_LOADER) - $(LINK_SHIM) gtk-shim.o gtkpanedview.o gtkscrolledview.o scmwidget.o \ - gtkio.o `pkg-config --libs gtk+-3.0 gthread-2.0` $(SHIM_LIBS) - -gtkscrolledview.o: gtkscrolledview.c gtkscrolledview.h - $(COMPILE_SHIM) `pkg-config --cflags gtk+-3.0` -c gtkscrolledview.c - -gtkscrolledview.c: gtkscrolledview.c.stay - cp -p gtkscrolledview.c.stay gtkscrolledview.c - -gtkpanedview.o: gtkpanedview.c gtkpanedview.h - $(COMPILE_SHIM) `pkg-config --cflags gtk+-3.0` -c gtkpanedview.c - -gtkpanedview.c: gtkpanedview.c.stay - cp -p gtkpanedview.c.stay gtkpanedview.c - -scmwidget.o: scmwidget.c scmwidget.h - $(COMPILE_SHIM) `pkg-config --cflags gtk+-3.0` -c scmwidget.c - -scmwidget.c: scmwidget.c.stay - cp -p scmwidget.c.stay scmwidget.c - -# COMPILE_SHIM will not do. COMPILE's DEFS conflict (cause warnings) -# with config.h. This is COMPILE_SHIM without DEFS. -gtkio.o: gtkio.c - $(CC) $(CPPFLAGS) $(CFLAGS) $(SHIM_CFLAGS) \ - `pkg-config --cflags gtk+-3.0` -I../microcode -c $< - -gtkio.c: gtkio.c.stay - cp -p gtkio.c.stay gtkio.c - -gtk-shim.o: gtk-shim.c gtk-shim.h ../lib/mit-scheme.h - $(COMPILE_SHIM) `pkg-config --cflags gtk+-3.0` -o $@ -c $< - -gtk-shim.c gtk-const.c gtk-types.bin: gtk-shim.h gtk.cdecl \ - Includes/*.cdecl Includes/*/*.cdecl - ( echo "(load-option 'FFI)"; \ - echo '(C-generate "gtk" "#include \"gtk-shim.h\"")' ) \ - | ../microcode/scheme --library ../lib --batch-mode - -gtk-const.bin: gtk-const.scm - echo '(sf "gtk-const")' \ - | ../microcode/scheme --library ../lib --batch-mode - -gtk-const.scm: gtk-const - ./gtk-const - -gtk-const: gtk-const.o - @rm -f $@ - $(CCLD) $(CFLAGS) $(LDFLAGS) -o $@ $< `pkg-config --libs gtk+-3.0` - -gtk-const.o: gtk-const.c - $(CC) $(CFLAGS) `pkg-config --cflags gtk+-3.0` -o $@ -c $< - -.PHONY: build install diff --git a/src/gtk/Makefile.in b/src/gtk/Makefile.in new file mode 100644 index 000000000..d64bfacfb --- /dev/null +++ b/src/gtk/Makefile.in @@ -0,0 +1,92 @@ +# 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 + +CFLAGS = @CFLAGS@ +CPPFLAGS = @CPPFLAGS@ +LDFLAGS = @LDFLAGS@ +LIBS = @LIBS@ + +all: gtk-shim.so gtk-types.bin gtk-const.bin + 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) + +install: + echo '(install-shim "gtk")' \ + | $(EXE) -- *.com *.bci *.pkd make.scm conses.png + +#install-optiondb +#install-manual "
  • GTK User's Manual
    • " + +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 + +gtk-shim.so: gtk-shim.o gtkpanedview.o gtkscrolledview.o scmwidget.o gtkio.o + 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 $< + +gtkpanedview.o: gtkpanedview.c gtkpanedview.h + 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 $< + +gtkio.o: gtkio.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) \ + `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) + +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 diff --git a/src/gtk/README b/src/gtk/README new file mode 100644 index 000000000..2c9d66788 --- /dev/null +++ b/src/gtk/README @@ -0,0 +1,16 @@ +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. + +To load via load-option, install the following in your optiondb.scm: + + (define-load-option 'GTK + (guarded-system-loader '(gtk) "gtk")) diff --git a/doc/gtk/check.scm b/src/gtk/check-doc.scm similarity index 94% rename from doc/gtk/check.scm rename to src/gtk/check-doc.scm index efae589a9..6e6f3d459 100644 --- a/doc/gtk/check.scm +++ b/src/gtk/check-doc.scm @@ -94,13 +94,11 @@ (loop (cdr items) (cons (car items) difference)))))) (define (check) - (let* ((texinfo (list->vector (call-with-input-file "../doc/gtk/gtk.texinfo" + (let* ((texinfo (list->vector (call-with-input-file "gtk.texinfo" read-lines))) (deffns (texinfo-deffns texinfo)) (dups (duplicates deffns)) - (pmodel (with-working-directory-pathname "gtk/" - (lambda () - (read-package-model "gtk" microcode-id/operating-system)))) + (pmodel (read-package-model "gtk" microcode-id/operating-system)) (bindings (append (pmodel/global-exports pmodel) (pmodel/package-bindings pmodel '(gtk)))) (missing (minus (minus bindings deffns) diff --git a/src/gtk/check-optiondb.scm b/src/gtk/check-optiondb.scm new file mode 100644 index 000000000..1bfbfe2de --- /dev/null +++ b/src/gtk/check-optiondb.scm @@ -0,0 +1,15 @@ +#| -*-Scheme-*- |# + +;;;; Test optiondb, includes the installed system's optiondb. + +(define-load-option 'GTK + (let ((pathname + (merge-pathnames "make" + (directory-pathname (current-load-pathname))))) + (named-lambda (gtk-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/check.scm b/src/gtk/check.scm new file mode 100644 index 000000000..0dd591901 --- /dev/null +++ b/src/gtk/check.scm @@ -0,0 +1,12 @@ +#| -*-Scheme-*- |# + +;;;; Test the gtk wrapper. + +(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 "check-optiondb" dirname))) + +(if (not (warn-errors? (lambda () (load-option 'GTK)))) + (load "gtk-check" (->environment '(GTK)))) \ No newline at end of file diff --git a/src/gtk/compile.scm b/src/gtk/compile.scm index b17cd648a..b7a9470de 100644 --- a/src/gtk/compile.scm +++ b/src/gtk/compile.scm @@ -7,41 +7,44 @@ (load-option 'SOS) (load-option 'FFI)) -(compile-system "gtk" (directory-pathname (current-load-pathname)) - ;; Temporary hack, until the released CREF loosens up - ;; and simply warns about new options it does not - ;; support, like the depends-on options commented out - ;; of gtk.pkg and recreated below. - 'dependencies - (let ( - ;; gtk.scm includes the Gtk c-includes, but does - ;; not otherwise use the FFI. - (c-types '("gtk-const.bin")) +(with-system-library-directories + '("./") + (lambda () + (compile-system "gtk" (directory-pathname (current-load-pathname)) + ;; Temporary hack, until the released CREF loosens up + ;; and simply warns about new options it does not + ;; support, like the depends-on options commented out + ;; of gtk.pkg and recreated below. + 'dependencies + (let ( + ;; gtk.scm includes the Gtk c-includes, but does + ;; not otherwise use the FFI. + (c-types '("gtk-const.bin")) - ;; The wrappers use the FFI, c-includes, and - ;; some integrable definitions in gtk.scm. - ;; Dependencies between them are rare. - (base '("gtk.bin" "gtk" - ;; "../runtime/ffi" ;; No workie???!!! - )) + ;; The wrappers use the FFI, c-includes, and + ;; some integrable definitions in gtk.scm. + ;; Dependencies between them are rare. + (base '("gtk.bin" "gtk" + ;; "../runtime/ffi" ;; No workie???!!! + )) - ;; Users of the toolkit interface do NOT use the - ;; FFI directly, and do not need integrable - ;; definitions. - (user '())) - `(("gtk" ,@c-types) - ("gobject" ,@base) - ("gio" ,@base) - ("pango" ,@base) - ("cairo" ,@base) - ("gtk-widget" ,@base) - ("scm-widget" ,@base) - ("fix-layout" "pango" "cairo" ,@base ,@c-types) - ("keys" ,@base ,@c-types) - ("gtk-graphics" ,@base) - ("main" ,@base) - ("thread" "main" ,@user) - ("gtk-ev" ,@base) - ("fix-demo" ,@user) - ("swat" ,@user) - ("swat-pole-zero" ,@user)))) \ No newline at end of file + ;; Users of the toolkit interface do NOT use the + ;; FFI directly, and do not need integrable + ;; definitions. + (user '())) + `(("gtk" ,@c-types) + ("gobject" ,@base) + ("gio" ,@base) + ("pango" ,@base) + ("cairo" ,@base) + ("gtk-widget" ,@base) + ("scm-widget" ,@base) + ("fix-layout" "pango" "cairo" ,@base ,@c-types) + ("keys" ,@base ,@c-types) + ("gtk-graphics" ,@base) + ("main" ,@base) + ("thread" "main" ,@user) + ("gtk-ev" ,@base) + ("fix-demo" ,@user) + ("swat" ,@user) + ("swat-pole-zero" ,@user)))))) \ No newline at end of file diff --git a/src/gtk/configure.ac b/src/gtk/configure.ac new file mode 100644 index 000000000..37eda064e --- /dev/null +++ b/src/gtk/configure.ac @@ -0,0 +1,90 @@ +dnl Process this file with autoconf to produce a configure script. + +AC_INIT([MIT/GNU Scheme gtk interface], + [0.1], + [bug-mit-scheme@gnu.org], + [mit-scheme-gtk]) +AC_CONFIG_SRCDIR([gtk.pkg]) +AC_CONFIG_HEADERS([config.h]) + +AC_COPYRIGHT( +[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, 2013 Massachusetts + Institute of Technology + +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. +]) + +AH_TOP([/* + +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, 2013 Massachusetts + Institute of Technology + +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. + +*/]) + +AC_ARG_WITH([gtk], + [AS_HELP_STRING([--with-gtk], + [Support the GNOME Toolkits [[auto]]])], + [], + [with_gtk=auto]) + +AC_CHECK_PROG([PKG_CONFIG], [pkg-config], [yes]) +AC_MSG_CHECKING([for gtk]) +if test "${with_gtk}" = "yes"; then + AC_MSG_RESULT([by request... yes]) +elif test "${with_gtk}" = "no"; then + AC_MSG_RESULT([by request... no]) +elif test "${with_gtk}" = "auto"; then + if pkg-config --exists gtk+-3.0 2>/dev/null; then + AC_MSG_RESULT([yes]) + with_gtk=yes + else + AC_MSG_RESULT([no Gtk 3.0... no]) + with_gtk=no + fi +fi + +if test "${with_gtk}" = "yes"; then + AC_CONFIG_FILES([Makefile]) +fi + +AC_SUBST([CFLAGS]) +AC_SUBST([CPPFLAGS]) +AC_SUBST([LDFLAGS]) +AC_SUBST([LIBS]) +AC_OUTPUT diff --git a/src/gtk/gtk-check.scm b/src/gtk/gtk-check.scm new file mode 100644 index 000000000..504a0ce2c --- /dev/null +++ b/src/gtk/gtk-check.scm @@ -0,0 +1,102 @@ +#| -*-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/") stringenvironment '(gtk gtk-widget))))) diff --git a/src/gtk/gtk.cdecl b/src/gtk/gtk.cdecl index 9203adcb7..6f9a654fa 100644 --- a/src/gtk/gtk.cdecl +++ b/src/gtk/gtk.cdecl @@ -21,7 +21,7 @@ USA. |# -;;;; C declarations for gtk.so. +;;;; C declarations for gtk-shim.so. (include "Includes/glib") (include "Includes/glib-object") diff --git a/doc/gtk/gtk.texinfo b/src/gtk/gtk.texinfo similarity index 100% rename from doc/gtk/gtk.texinfo rename to src/gtk/gtk.texinfo diff --git a/src/gtk/gtkio.c.stay b/src/gtk/gtkio.c similarity index 86% rename from src/gtk/gtkio.c.stay rename to src/gtk/gtkio.c index 9010cdd64..8534508ee 100644 --- a/src/gtk/gtkio.c.stay +++ b/src/gtk/gtkio.c @@ -23,29 +23,26 @@ USA. /* SchemeSource -- the custom GSource that runs Scheme in an idle task. */ -#include "scheme.h" -#include "option.h" -#include "ux.h" -#include "ossig.h" -#include "osctty.h" -#include "ostty.h" -#include "ostop.h" -#include "osio.h" -#include "osenv.h" -#include "osproc.h" -#include "osscheme.h" -#include "uxtrap.h" -#include "uxsig.h" -#include "uxutil.h" -#include "critsec.h" - -#include -#include +#include #include -#define MIT_SCHEME /* Avoid re-declaring things included above. */ -#include "pruxffi.h" - +#include +#include +#include + +/* Presumed externs/const of the Gtk-ready machine. */ +extern double OS_real_time_clock (void); +extern int OS_process_any_status_change (void); +extern int interrupts_p (void); +extern int OS_select_registry_length (unsigned long registry); +extern void OS_select_registry_entry (unsigned long registry, + int i, int *fd, unsigned int *mode); +extern void Interpret (int pop_return_p); +#define SELECT_MODE_READ 1 +#define SELECT_MODE_WRITE 2 extern void alienate_float_environment (void); +extern void foreach_async_signal (void(*func)(int signo)); +extern void OS_syserr_names (unsigned long *, const char ***); + static void init_signal_handling (void); struct _SchemeSource @@ -77,8 +74,7 @@ static void set_registry (SchemeSource * source, GSList * new, double time); static SchemeSource * scheme_source = NULL; static gboolean tracing_gtk_select = 0; static void trace (const char *format, ...); -static gboolean interrupt_p (void); -static GSList * gtk_registry (select_registry_t registry); +static GSList * gtk_registry (unsigned long registry); static int slice_counter = 0; static GtkWidget * slice_window = NULL; @@ -96,28 +92,12 @@ trace (const char * format, ...) va_start (args, format); if (tracing_gtk_select) { - voutf_console (format, args); - outf_flush_console (); + vfprintf (stderr, format, args); + fflush (stderr); } va_end (args); } -static gboolean -interrupt_p (void) -{ - /* Ignores the INT_MASK, which is interrupt-mask/gc-ok per - call-alien. That mask keeps callbacks from wandering onto other - threads. Ignoring it allows the scheme_source to return to the - gtk-thread, where call-alien will restore gtk-thread's mask, - unmasking whatever interrupt was pending (assuming gtk-thread - runs with all interrupts unmasked). */ - - /* return (INTERRUPT_PENDING_P (INT_Mask)); */ - /* return (((PENDING_INTERRUPTS ()) & (INT_Mask)) != 0); */ - /* return ((((GET_INT_MASK & GET_INT_CODE)) & (INT_Mask)) != 0); */ - return (GET_INT_CODE); -} - static gboolean scheme_source_prepare (GSource * source, gint * timeout) { @@ -129,12 +109,12 @@ scheme_source_prepare (GSource * source, gint * timeout) SchemeSource * src = (SchemeSource *)source; if (src->runnable - || interrupt_p () + || interrupts_p () || OS_process_any_status_change ()) { trace (";scheme_source_prepare: ready (%s)\n", src->runnable ? "thread" - : interrupt_p () ? "interrupt" + : interrupts_p () ? "interrupt" : "subprocess"); *timeout = 0; return (TRUE); @@ -177,13 +157,13 @@ scheme_source_check (GSource * source) if (src->time_limit == 0.0 || src->runnable - || interrupt_p () + || interrupts_p () || OS_process_any_status_change () || pending_io (src)) { trace (";scheme_source_check: ready (%s)\n", src->runnable ? "thread" - : interrupt_p () ? "interrupt" + : interrupts_p () ? "interrupt" : OS_process_any_status_change () ? "subprocess" : src->time_limit == 0.0 ? "" : "i/o"); return (TRUE); @@ -221,8 +201,8 @@ pending_io (SchemeSource * src) GPollFD * gfd = scan->data; if (gfd->revents != 0) { - outf_console (";scheme_source_check: i/o ready on %d\n", - gfd->fd); + fprintf (stderr, ";scheme_source_check: i/o ready on %d\n", + gfd->fd); } scan = scan->next; } @@ -407,15 +387,15 @@ run_gtk (unsigned long registry, double time) simulated poll should not re-enter Scheme until TIME. */ set_registry (scheme_source, - gtk_registry ((select_registry_t)registry), + gtk_registry (registry), time); if (tracing_gtk_select) { GSList * gpollfds = scheme_source->gpollfds; gchar * fdstr = gpollfds_string (gpollfds); - outf_console (";run_gtk%s%s until %.1f\n", - gpollfds == NULL ? "" : " waiting on", fdstr, time); - outf_flush_console (); + fprintf (stderr, ";run_gtk%s%s until %.1f\n", + gpollfds == NULL ? "" : " waiting on", fdstr, time); + fflush (stderr); if (fdstr[0] != '\0') g_free (fdstr); } @@ -468,7 +448,7 @@ yield_gtk (void) | ((((revents) & G_IO_HUP) != 0) ? SELECT_MODE_HUP : 0)) static GSList * -gtk_registry (select_registry_t registry) +gtk_registry (unsigned long registry) { /* Construct Gtk's version of a select_registry_t. */ @@ -600,19 +580,21 @@ gtk_select_trace (gboolean trace_p) itself running in the scheme_thread, it invokes the original handler. */ -extern void OS_syserr_names (unsigned long * length, const char *** names); +#include +#include static const char * errno_name (int err); static void complain (const char *format, ...); static pthread_t scheme_thread; -static GSList *old_handlers = NULL; +static struct handler_record * old_handlers = NULL; struct handler_record { int signo; - Tsignal_handler handler; + void (*handler)(int, siginfo_t *, void *); + struct handler_record *next; }; -Tsignal_handler_result +void signal_forwarder (int signo, siginfo_t *siginfo, void *ptr) { pthread_t self; @@ -620,16 +602,14 @@ signal_forwarder (int signo, siginfo_t *siginfo, void *ptr) self = pthread_self (); if (self == scheme_thread) { - GSList * scan; + struct handler_record * scan; scan = old_handlers; while (scan != NULL) { - struct handler_record * old = scan->data; - if (old->signo == signo) + if (scan->signo == signo) { - trace ("signal_forwarder: running handler\n"); - (old->handler)(signo, siginfo, ptr); + (scan->handler)(signo, siginfo, ptr); return; } scan = scan->next; @@ -640,7 +620,6 @@ signal_forwarder (int signo, siginfo_t *siginfo, void *ptr) { int err; - trace (";signal_forwarder: forwarding signo %d\n", signo); err = pthread_kill (scheme_thread, signo); if (err != 0) { @@ -651,35 +630,48 @@ signal_forwarder (int signo, siginfo_t *siginfo, void *ptr) } } -void +static void init_signal_forwarder (int signo) { int err; struct handler_record *hrec; - Tsignal_handler handler; struct sigaction act; err = sigaction (signo, 0, (&act)); if (err != 0) - complain ("init_signal_forwarder: sigaction access failed\n"); - handler = act.sa_sigaction; - if ((handler == ((Tsignal_handler) SIG_DFL)) - || (handler == (Tsignal_handler) SIG_IGN)) + { + complain ("init_signal_forwarder: sigaction access failed\n"); + return; + } + + if (((act.sa_flags & SA_SIGINFO) == 0) + && ((act.sa_handler == SIG_DFL) + || (act.sa_handler == SIG_IGN))) return; - act.sa_sigaction = &signal_forwarder; + if ((act.sa_flags & SA_SIGINFO) == 0) + { + complain ("init_signal_forwarder: no SA_SIGINFO\n"); + return; + } + hrec = malloc (sizeof (struct handler_record)); + if (hrec == NULL) + { + complain ("init_signal_forwarder: malloc failed\n"); + return; + } + hrec->signo = signo; + hrec->handler = act.sa_sigaction; + hrec->next = old_handlers; + act.sa_sigaction = &signal_forwarder; err = sigaction (signo, &act, 0); if (err != 0) complain ("init_signal_forwarder: sigaction modify failed\n"); - - hrec = g_malloc (sizeof (struct handler_record)); - hrec->signo = signo; - hrec->handler = handler; - old_handlers = g_slist_prepend (old_handlers, hrec); + old_handlers = hrec; } -void +static void init_signal_handling (void) { scheme_thread = pthread_self (); @@ -703,7 +695,7 @@ complain (const char *format, ...) { va_list args; va_start (args, format); - voutf_console (format, args); - outf_flush_console (); + vfprintf (stderr, format, args); + fflush (stderr); va_end (args); } diff --git a/src/gtk/gtkpanedview.c.stay b/src/gtk/gtkpanedview.c similarity index 100% rename from src/gtk/gtkpanedview.c.stay rename to src/gtk/gtkpanedview.c diff --git a/src/gtk/gtkscrolledview.c.stay b/src/gtk/gtkscrolledview.c similarity index 100% rename from src/gtk/gtkscrolledview.c.stay rename to src/gtk/gtkscrolledview.c diff --git a/src/gtk/make.scm b/src/gtk/make.scm index e4546bee8..61e2fe485 100644 --- a/src/gtk/make.scm +++ b/src/gtk/make.scm @@ -19,9 +19,6 @@ Load the Gtk option. |# (ld 'SUBPROCESS) ;; Hacked in main.scm. (ld 'SOS) (ld 'FFI) ;; Referenced in gtk.pkg. - (with-loader-base-uri - (system-library-uri "gtk/") - (lambda () - (load-package-set "gtk")))) + (load-package-set "gtk")) (add-subsystem-identification! "Gtk" '(0 4)) ((access gtk-start (->environment '(gtk main)))))) \ No newline at end of file diff --git a/src/gtk/scmwidget.c.stay b/src/gtk/scmwidget.c similarity index 100% rename from src/gtk/scmwidget.c.stay rename to src/gtk/scmwidget.c diff --git a/src/gtk/swat-pole-zero.scm b/src/gtk/swat-pole-zero.scm new file mode 100644 index 000000000..708f548f0 --- /dev/null +++ b/src/gtk/swat-pole-zero.scm @@ -0,0 +1,495 @@ +;;; -*- Scheme -*- + +(declare (usual-integrations)) + +;;;Demo of DT frequency response by frobbing poles and zeros + +(define half-window-size 200) +(define zero-size 5) +(define pole-size 4) +(define trim 10) +(define zero-color "violetred") +(define pole-color "blue") +(define canvas-color "white") +(define text-font "CourR12") + + +(define symbol-font + "-adobe-symbol-medium-r-normal--14-100-100-100-p-85-adobe-fontspecific") + +(define tracking-coords? #F) +(define time-to-update-plot? #F) +(define LOCATION 'later) ; active variable +(define all-zeros '()) ; alist of zeros(objects)/coords +(define all-poles '()) ; alist of poles(objects)/coords + +(define number-of-points 100) +(define max-w 3.14159) + +;;hack to print numbers to three decimals +(define (unsigned->string n) + (let* ((int-part (floor n)) + (frac-part (- n int-part)) + (dec (floor->exact (* frac-part 1000))) + (string-dec (number->string dec)) + (padded-string-dec + (cond ((< dec 10) (string-append "00" string-dec)) + ((< dec 100) (string-append "0" string-dec)) + (else string-dec)))) + (string-append (number->string (floor->exact int-part)) + "." + padded-string-dec))) + +(define (our-cx->string z) + (let* ((r (real-part z)) + (i (imag-part z)) + (rs (unsigned->string (abs r))) + (is (unsigned->string (abs i))) + (signed-r + (if (< r 0) + (string-append "-" rs) + rs)) + (signed-i + (if (< i 0) + (string-append "-" is) + (string-append "+" is)))) + (string-append signed-r signed-i "j"))) + +(define (our-real->string r) + (let* ((rs (unsigned->string (abs r))) + (signed-r + (if (< r 0) + (string-append "-" rs) + rs))) + signed-r)) + + +(define (z->canvas-coords z) + (let ((x (real-part z)) + (y (imag-part z))) + (list + (round->exact + (+ (* x (- half-window-size (* 2 trim))) + half-window-size)) + (round->exact + (+ (* y (- (* 2 trim) half-window-size)) + half-window-size))))) + +(define (canvas-coords->z xy) + (let ((x (exact->inexact (car xy))) + (y (exact->inexact (cadr xy)))) + (let ((real (/ (- x half-window-size) + (- half-window-size (* 2 trim)))) + (imag (/ (- y half-window-size) + (- (* 2 trim) half-window-size)))) + (+ real (* imag +i))))) + +;;; Pole/Zero Movement +(define (move-with-conjugate-pair pole-zero obj1 obj2) + (let ((last-x 'later) + (last-y 'later)) + (define (keep-track-of-coords x y) + (set! last-x x) + (set! last-y y) + (if tracking-coords? + (let ((z (canvas-coords->z (list last-x last-y)))) + (set-active-variable! LOCATION (our-cx->string z))))) + (define (store-coords) + (let* ((zero-entry (assq obj1 all-zeros)) + (obj1-entry + (if zero-entry zero-entry (assq obj1 all-poles))) + (obj2-entry + (if zero-entry + (assq obj2 all-zeros) + (assq obj2 all-poles))) + (z (canvas-coords->z (list last-x last-y)))) + (set-cdr! obj1-entry z) + (set-cdr! obj2-entry (conjugate z)))) + (add-event-handler! + obj1 + "" + (lambda (x y) + (set! time-to-update-plot? #F) + (keep-track-of-coords x y)) + "%x" "%y") + (add-event-handler! + obj1 + "" + (lambda () + (store-coords) + (maybe-update-plot (pole-zero 'graph-canvas)) + )) + (add-event-handler! + obj1 + "" + (lambda (x y) + (ask-widget obj1 `(move ,(- x last-x) ,(- y last-y))) + (ask-widget obj2 `(move ,(- x last-x) ,(- last-y y))) + (keep-track-of-coords x y)) + "%x" "%y"))) + +(define (move-by-itself pole-zero obj) + (let ((last-x 'later)) + (define (keep-track-of-coords x) + (set! last-x x) + (let ((z (canvas-coords->z (list last-x half-window-size)))) + (if tracking-coords? + (set-active-variable! LOCATION (our-real->string z))))) + (define (store-coords) + (let ((entry + (let ((zero (assq obj all-zeros))) + (if zero zero (assq obj all-poles)))) + (z (real-part (canvas-coords->z (list last-x 0))))) + (set-cdr! entry z))) + (add-event-handler! + obj + "" + (lambda (x) + (set! time-to-update-plot? #F) + (keep-track-of-coords x)) + "%x") + (add-event-handler! + obj + "" + (lambda () + (store-coords) + (maybe-update-plot (pole-zero 'graph-canvas)) + )) + (add-event-handler! + obj + "" + (lambda (x) + (ask-widget obj `(move ,(- x last-x) 0)) + (keep-track-of-coords x)) + "%x"))) + + +;;; This isn't quite right. Time-to-update-plot? might be set to #F +;;; and then back to #T inside the 2 sec interval, so the update will +;;; come too soon. +(define (maybe-update-plot graph-canvas) + (set! time-to-update-plot? #T) + (after-delay + 2 + (lambda () + (if time-to-update-plot? + (plot-pole-zero graph-canvas))))) + + +;;; Zeros +(define (make-zero canvas xy) + (let ((x (car xy)) + (y (cadr xy))) + (let ((zero + (make-oval-on-canvas canvas + (- x zero-size) (- y zero-size) + (+ x zero-size) (+ y zero-size)))) + (set! all-zeros (cons (cons zero (canvas-coords->z xy)) + all-zeros)) + (ask-widget zero `(configure -outline ,zero-color -fill ,canvas-color -width 2)) + zero))) + +(define (make-single-zero pole-zero x) + (let ((canvas (pole-zero 'diagram-canvas))) + (let ((z (make-zero canvas (list x half-window-size)))) + (move-by-itself pole-zero z) + z))) + +(define (make-zero-pair pole-zero x y) + (let ((canvas (pole-zero 'diagram-canvas))) + (let ((zero (canvas-coords->z (list x y)))) + (let ((other-pos + (z->canvas-coords (conjugate zero)))) + (let ((z1 (make-zero canvas (list x y))) + (z2 (make-zero canvas other-pos))) + (move-with-conjugate-pair pole-zero z1 z2) + (move-with-conjugate-pair pole-zero z2 z1)))))) + + +;;; Poles +(define (make-pole canvas xy) + (let ((x (car xy)) + (y (cadr xy))) + (let* ((line1 + (make-line-on-canvas canvas + (- x pole-size) (- y pole-size) + (+ x pole-size) (+ y pole-size))) + (line2 + (make-line-on-canvas canvas + (- x pole-size) (+ y pole-size) + (+ x pole-size) (- y pole-size))) + (pole (make-canvas-item-group canvas (list line1 line2)))) + (set! all-poles (cons (cons pole (canvas-coords->z xy)) + all-poles)) + (ask-widget pole `(configure -fill ,pole-color -width 2)) + pole))) + +(define (make-single-pole pole-zero x) + (let ((canvas (pole-zero 'diagram-canvas))) + (let ((p (make-pole canvas (list x half-window-size)))) + (move-by-itself pole-zero p) + p))) + +(define (make-pole-pair pole-zero x y) + (let ((canvas (pole-zero 'diagram-canvas))) + (let ((pole (canvas-coords->z (list x y)))) + (let ((other-pos + (z->canvas-coords (conjugate pole)))) + (let ((p1 (make-pole canvas (list x y))) + (p2 (make-pole canvas other-pos))) + (move-with-conjugate-pair pole-zero p1 p2) + (move-with-conjugate-pair pole-zero p2 p1)))))) + +;;; Button that switches from one label to another + +(define (make-switch color to-switch) + ;;to-switch is list ((text command) (text command)) + (let ((n (length to-switch)) + (button (make-button)) + (state #F)) + (define (switch-to-state i) + (set! state i) + ((cadr (list-ref to-switch i))) + (ask-widget button `(configure -text ,(car (list-ref to-switch i))))) + (ask-widget button `(configure -background ,color)) + (switch-to-state 0) + (set-callback! button + (lambda () + (switch-to-state (modulo (+ state 1) n)))) + button)) + +;;; Demo +(define (make-pole-zero) + (set! all-zeros '()) + (set! all-poles '()) + (let ((diagram-canvas (make-canvas `(-width ,(* 2 half-window-size) + -height ,(* 2 half-window-size)))) + (graph-canvas #F) + (pz 'later) + (shape-size 'later) + (single-maker 'later) + (pair-maker 'later)) + + (define (switch-to-zeros) + (set! shape-size zero-size) + (set! single-maker make-single-zero) + (set! pair-maker make-zero-pair)) + + (define (switch-to-poles) + (set! shape-size pole-size) + (set! single-maker make-single-pole) + (set! pair-maker make-pole-pair)) + + (let* ((maker-button (make-switch "yellow" + `(("Zeros" ,switch-to-zeros) + ("Poles" ,switch-to-poles)))) + (clear-button (make-button '(-text "Clear"))) + (show-coords? (make-active-variable)) + (coords-button + (make-checkbutton `(-text "Show Coords?" -variable ,show-coords?))) + (coords-display (make-label)) + (plot-button (make-button '(-text "Plot")))) + + (set! LOCATION (make-active-variable)) + (ask-widget coords-display `(configure -width 13 -background ,canvas-color + -relief sunken -textvariable ,LOCATION + -font ,text-font)) + (for-each (lambda (b) + (ask-widget b `(configure -background "yellow" -font ,text-font))) + (list maker-button clear-button coords-button plot-button)) + (ask-widget diagram-canvas `(configure -background ,canvas-color)) + (on-death! diagram-canvas 'little-brother-canvas + (lambda () (if graph-canvas (swat-close graph-canvas)))) + + (set-callback! + clear-button + (lambda () + (for-each (lambda (entry) (ask-widget (car entry) '(delete))) + all-zeros) + (for-each (lambda (entry) (ask-widget (car entry) '(delete))) + all-poles) + (set-active-variable! LOCATION "") + (cond (graph-canvas + (ask-widget graph-canvas '(delete all)) + (draw-axes graph-canvas))) + (set! all-zeros '()) + (set! all-poles '()))) + + (set-callback! + coords-button + (lambda () + (if (checkbutton-variable-on? show-coords?) + (set! tracking-coords? #T) + (begin + (set-active-variable! LOCATION "") + (set! tracking-coords? #F))))) + (set-callback! + plot-button + (lambda () + (cond ((not graph-canvas) + (set! graph-canvas + (make-canvas `(-width ,(* 2 half-window-size) + -height ,(* 2 half-window-size)))) + (ask-widget graph-canvas `(configure -background ,canvas-color)) + (swat-open graph-canvas '-title "Magnitude of Frequency Response") + (on-death! graph-canvas 'big-brother-canvas + (lambda () (set! graph-canvas #F))))) + (plot-pole-zero graph-canvas))) + (add-event-handler! + diagram-canvas + "" + (lambda (x y) + (set! time-to-update-plot? #F) + (if (< (abs (- y half-window-size)) shape-size) + (single-maker pz x) + (pair-maker pz x y))) + "%x" "%y") + + (let ((me (make-vbox diagram-canvas + (make-hbox maker-button clear-button coords-button + coords-display plot-button)))) + (swat-open me '-title "Pole-Zero Diagram") + (let ((x-axis (make-line-on-canvas + diagram-canvas + trim half-window-size + (- (* 2 half-window-size) trim) half-window-size)) + (y-axis (make-line-on-canvas + diagram-canvas + half-window-size trim + half-window-size (- (* 2 half-window-size) trim))) + (unit-circle (make-oval-on-canvas + diagram-canvas + (* 2 trim) (* 2 trim) + (* 2 (- half-window-size trim)) + (* 2 (- half-window-size trim))))) + (ask-widget x-axis '(configure -arrow last)) + (ask-widget y-axis '(configure -arrow first)) + (ask-widget unit-circle '(configure -outline "gray"))) + + (set! pz + (lambda (message) + (case message + ((graph-canvas) graph-canvas) + ((diagram-canvas) diagram-canvas) + ((add-zero) + (lambda (z) + (let ((xy (z->canvas-coords z))) + (if (= (imag-part z) 0) + (make-single-zero pz (car xy)) + (make-zero-pair pz (car xy) (cadr xy)))))) + ((add-pole) + (lambda (p) + (let ((xy (z->canvas-coords p))) + (if (= (imag-part p) 0) + (make-single-pole pz (car xy)) + (make-pole-pair pz (car xy) (cadr xy)))))) + (else "Unknown message -- MAKE-POLE-ZERO" message)))) + pz)))) + + +(define (add-butterworth-poles pole-zero-diagram n) + (define pi (* (atan 1 1) 4)) + (define (make-index-list n start) + (if (> start n) + '() + (cons start (make-index-list n (+ start 1))))) + (let ((index-list (make-index-list n (+ (ceiling->exact (/ n 2)) 1))) + (w (exp (/ (* 2 +i pi) (* 2 n))))) + (for-each (lambda (pole) + ((pole-zero-diagram 'add-pole) pole)) + (map (lambda (s) + (let ((t 1)) + (/ (+ 1 (* (/ t 2) s)) + (- 1 (* (/ t 2) s))))) + (map (lambda (k) (expt w (- k .5))) + index-list))) + (let loop ((z 1)) + (if (> z n) + 'done + (begin ((pole-zero-diagram 'add-zero) -1) + (loop (1+ z))))) + (plot-pole-zero (pole-zero-diagram 'graph-canvas)))) + + +(define (plot-pole-zero graph-canvas) + (cond (graph-canvas + (ask-widget graph-canvas '(delete all)) + (draw-axes graph-canvas) + (plot-magnitude graph-canvas)))) + +(define (plot-magnitude graph-canvas) + (let ((zero-locations (map cdr all-zeros)) + (pole-locations (map cdr all-poles))) + (let ((fcn + (lambda (x) + (let ((jw (exp (* x +i)))) + (let ((numer + (apply * (map (lambda (z) (magnitude (- jw z))) + zero-locations))) + (denom + (apply * (map (lambda (z) (magnitude (- jw z))) + pole-locations)))) + (if (< denom 1.e-10) + 1.e5 + (/ numer denom))))))) + (plot-graph-on-canvas + graph-canvas + (let loop ((index 0) (points '())) + (if (> index number-of-points) + points + (let ((w (* index (/ max-w number-of-points)))) + (loop (+ index 1) + (cons (cons w (fcn w)) points))))))))) + +(define (plot-graph-on-canvas canvas graph) + (let* ((maxval (apply max (map cdr graph))) + (canvas-points + (map (lambda (graph-point) + (magnitude-coords->canvas-coords graph-point maxval)) + graph))) + (let loop ((rest-points (cdr canvas-points)) + (this-point (car canvas-points))) + (if (null? rest-points) + 'done + (let ((next-point (car rest-points))) + (make-line-on-canvas canvas + (car this-point) + (cdr this-point) + (car next-point) + (cdr next-point)) + (loop (cdr rest-points) + (car rest-points))))) + (let ((maxval-display + (make-text-on-canvas + canvas (* 3 trim) (* 2 trim) `(-text ,(our-real->string maxval))))) + (ask-widget maxval-display + `(configure -anchor sw -font ,symbol-font))))) + + +(define (magnitude-coords->canvas-coords xy max-mag) + (let ((x (car xy)) + (y (cdr xy))) + (cons (round->exact (+ (* x (/ (- (* 2 half-window-size) (* 4 trim)) max-w)) + (* 2 trim))) + (round->exact (+ (* y (/ (- (* 4 trim) (* 2 half-window-size)) max-mag)) + (* 2 (- half-window-size trim))))))) + + +(define (draw-axes graph-canvas) + (let ((x-axis (make-line-on-canvas + graph-canvas + trim (* 2 (- half-window-size trim)) + (- (* 2 half-window-size) trim) + (* 2 (- half-window-size trim)))) + (y-axis (make-line-on-canvas + graph-canvas + (* 2 trim) trim + (* 2 trim) (- (* 2 half-window-size) trim))) + (pi (make-text-on-canvas + graph-canvas + (* 2 (- half-window-size trim)) (- (* 2 half-window-size) trim) + '(-text "p")))) + (ask-widget x-axis '(configure -arrow last)) + (ask-widget y-axis '(configure -arrow first)) + (ask-widget pi `(configure -anchor e -font ,symbol-font)))) + diff --git a/tests/gtk/test-gport-performance.scm b/src/gtk/test-gport-performance.scm similarity index 100% rename from tests/gtk/test-gport-performance.scm rename to src/gtk/test-gport-performance.scm diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c index f6900fa9a..146de8ba3 100644 --- a/src/microcode/pruxffi.c +++ b/src/microcode/pruxffi.c @@ -1085,3 +1085,13 @@ DEFINE_PRIMITIVE ("OUTF-ERROR", Prim_outf_error, 1, 1, 0) PRIMITIVE_RETURN (UNSPECIFIC); } } + +int +interrupts_p (void) +{ + /* Just the pending interrupts bitmap, ignoring the INT_MASK. */ + /* This is mainly for src/gtk/gtkio.c, which finds pending_ + interrupts_p() useless; it is always /gc-ok. */ + + return (GET_INT_CODE); +} diff --git a/tests/check.scm b/tests/check.scm index 015901a62..609db138f 100644 --- a/tests/check.scm +++ b/tests/check.scm @@ -54,7 +54,6 @@ USA. "runtime/test-regsexp" ("runtime/test-wttree" (runtime wt-tree)) "ffi/test-ffi.scm" - "gtk/test-gtk.scm" )) (with-working-directory-pathname diff --git a/tests/gtk/test-gtk.scm b/tests/gtk/test-gtk.scm deleted file mode 100644 index eb89591f3..000000000 --- a/tests/gtk/test-gtk.scm +++ /dev/null @@ -1,91 +0,0 @@ -#| -*-Scheme-*- - -Copyright (C) 2012 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 - -(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) - (load "../src/planetarium/mit-scheme") - (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 (named-lambda (malloced-aliens) - (access malloced-aliens ffi)))) - - (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 '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