Remove the Gtk wrapper from the core build tree.
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:
Makefile
make-common
ffi/Makefile
- gtk/Makefile
imail/Makefile
ref-manual/Makefile
sos/Makefile
+++ /dev/null
-# 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
<li><a href="mit-scheme-sos/index.html">SOS Reference Manual</a></li>
<li><a href="mit-scheme-imail/index.html">IMAIL User's Manual</a></li>
<li><a href="mit-scheme-ffi/index.html">FFI User's Manual</a></li>
-<li><a href="mit-scheme-gtk/index.html">GTK User's Manual</a></li>
</ul>
</body>
check:
./microcode/scheme --library lib --batch-mode \
--load ../tests/check </dev/null
- @if [ -d ../doc/gtk ]; then \
- echo ./microcode/scheme --load ../doc/gtk/check; \
- ./microcode/scheme --library lib --batch-mode \
- --load ../doc/gtk/check </dev/null; \
- else \
- echo "; Warning: Gtk documentation not checked."; \
- fi
all-native: lib/runtime.com
all-native: lib/all.com
* "etc" contains miscellaneous files for building the program.
-* "gtk" provides a Schemely interface to GNOME. It features a Scheme
- canvas widget and limited SWAT emulation.
-
* "rcs" is a parser for RCS files. It also contains a program for
generating merged log files, in RCS or ChangeLog format, for
directory trees under RCS or CVS control.
. etc/functions.sh
-INSTALLED_SUBDIRS="cref edwin ffi gtk imail sf sos ssp star-parser xml"
+INSTALLED_SUBDIRS="cref edwin ffi imail sf sos ssp star-parser xml"
OTHER_SUBDIRS="6001 compiler rcs runtime win32 xdoc microcode"
# lib
rcs/TAGS,include
\f
ffi/TAGS,include
-\f
-gtk/TAGS,include
fi
DEFAULT_TARGET=${with_default_target}
-AC_ARG_WITH([gtk],
- [AS_HELP_STRING([--with-gtk],
- [Support the GNOME Toolkits [[auto]]])],
- [],
- [with_gtk=auto])
-
AC_CANONICAL_HOST
MIT_SCHEME_NATIVE_CODE([${enable_native_code}],[${host_cpu}])
fi
fi
-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
-
AC_SUBST([DEFAULT_TARGET])
AC_SUBST([ALL_TARGET])
AC_SUBST([INSTALL_COM])
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
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 <<EOF
(begin
(define-load-option 'FFI
(guarded-system-loader '(ffi) "ffi"))
-(define-load-option 'GTK
- (guarded-system-loader '(gtk) "gtk"))
-
(define-load-option 'IMAIL
(guarded-system-loader '(edwin imail) "imail"))
+++ /dev/null
-gtk-const
-gtk-const.c
-gtk-const.scm
-gtk-shim.c
-gtk-shim.so
-scmwidget.c
-gtkio.c
-swat-pole-zero.scm
+++ /dev/null
-#!/bin/sh
-
-set -e
-
-if [ ${#} -ne 1 ]; then
- echo "usage: ${0} <command>"
- 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
+++ /dev/null
-#-*-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
--- /dev/null
+# 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 "<li><a href=\"mit-scheme-gtk/index.html\">GTK User's Manual</a></li>"
+
+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
--- /dev/null
+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"))
(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)
--- /dev/null
+#| -*-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
--- /dev/null
+#| -*-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
(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
--- /dev/null
+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
--- /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 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)))))))
\ No newline at end of file
#| -*-Scheme-*-
-Copyright (C) 2010, 2011, 2012 Matthew Birkholz
+Copyright (C) 2010, 2011, 2012, 2013 Matthew Birkholz
This file is part of an extension to MIT/GNU Scheme.
(named-lambda (test-copy-integrity)
(with-working-directory-pathname cwd
(lambda ()
- (let ((file1 "../../src/README.txt")
+ (let ((file1 "../README.txt")
(file2 "test-copy-1.txt"))
(gcp file1 file2)
(assert-equal (md5-file file2) (md5-file file1))))))))
(make-gtk-event-viewer-demo)
(make-fix-layout-demo)
(make-pole-zero)
- (make-tellurion)
(let loop ()
(if (not (null? (access toplevel-windows
(->environment '(gtk gtk-widget)))))
|#
-;;;; C declarations for gtk.so.
+;;;; C declarations for gtk-shim.so.
\f
(include "Includes/glib")
(include "Includes/glib-object")
/* 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 <pthread.h>
-#include <glib.h>
+#include <mit-scheme.h>
#include <gtk/gtk.h>
-#define MIT_SCHEME /* Avoid re-declaring things included above. */
-#include "pruxffi.h"
-
+#include <glib.h>
+#include <math.h>
+#include <stdlib.h>
+
+/* 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
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;
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)
{
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);
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);
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;
}
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);
}
| ((((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. */
itself running in the scheme_thread, it invokes the original
handler. */
-extern void OS_syserr_names (unsigned long * length, const char *** names);
+#include <signal.h>
+#include <pthread.h>
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;
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;
{
int err;
- trace (";signal_forwarder: forwarding signo %d\n", signo);
err = pthread_kill (scheme_thread, signo);
if (err != 0)
{
}
}
-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 ();
{
va_list args;
va_start (args, format);
- voutf_console (format, args);
- outf_flush_console ();
+ vfprintf (stderr, format, args);
+ fflush (stderr);
va_end (args);
}
(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
--- /dev/null
+;;; -*- 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
+ "<ButtonPress-1>"
+ (lambda (x y)
+ (set! time-to-update-plot? #F)
+ (keep-track-of-coords x y))
+ "%x" "%y")
+ (add-event-handler!
+ obj1
+ "<ButtonRelease-1>"
+ (lambda ()
+ (store-coords)
+ (maybe-update-plot (pole-zero 'graph-canvas))
+ ))
+ (add-event-handler!
+ obj1
+ "<B1-Motion>"
+ (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
+ "<ButtonPress-1>"
+ (lambda (x)
+ (set! time-to-update-plot? #F)
+ (keep-track-of-coords x))
+ "%x")
+ (add-event-handler!
+ obj
+ "<ButtonRelease-1>"
+ (lambda ()
+ (store-coords)
+ (maybe-update-plot (pole-zero 'graph-canvas))
+ ))
+ (add-event-handler!
+ obj
+ "<B1-Motion>"
+ (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
+ "<Double-ButtonPress-1>"
+ (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))))
+
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);
+}
"runtime/test-regsexp"
("runtime/test-wttree" (runtime wt-tree))
"ffi/test-ffi.scm"
- "gtk/test-gtk.scm"
))
(with-working-directory-pathname
+++ /dev/null
-#| -*-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<?))
- (gio (sort (gls "../runtime/") string<?)))
- (assert-equal gio native
- 'EXPRESSION '(GLS "../runtime/"))))))))
-
- (define-test 'gtk-demos
- (lambda ()
- (with-gc-notification! #t await-closed-demos)
- (gc-flip)))
-
- (define-test 'gtk-demos.callbacks
- (lambda ()
- (assert-= (car (registered-callback-count))
- 0
- 'EXPRESSION '(REGISTERED-CALLBACK-COUNT))))
-
- (define-test 'gtk-demos.mallocs
- (lambda ()
- (assert-= (length (malloced-aliens))
- 0
- 'EXPRESSION '(LENGTH (MALLOCED-ALIENS))))))
-
-(if (and (not (warn-errors? (lambda () (load-option 'gtk))))
- (let ((s (get-environment-variable "DISPLAY")))
- (and (string? s) (not (string-null? s)))))
- (main))
\ No newline at end of file
projects / mit-scheme.git / commitdiff