commit 606245fc41918819dcb9c9278a61bf62373b8f19
Author: marting <marting>
Date:   Tue Sep 14 12:45:02 1999 +0000

    *** empty log message ***

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..da8168b
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,28 @@
+# CVS default ignores begin
+tags
+TAGS
+.make.state
+.nse_depinfo
+*~
+\#*
+.#*
+,*
+_$*
+*$
+*.old
+*.bak
+*.BAK
+*.orig
+*.rej
+.del-*
+*.a
+*.olb
+*.o
+*.obj
+*.so
+*.exe
+*.Z
+*.elc
+*.ln
+core
+# CVS default ignores end
diff --git a/COPYING b/COPYING
new file mode 100644
index 0000000..704f0ba
--- /dev/null
+++ b/COPYING
@@ -0,0 +1,46 @@
+Copyright (c) 1993-1999 Richard Kelsey and Jonathan Rees
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+3. The name of the authors may not be used to endorse or promote products
+   derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+
+Distributing Autoconf Output
+****************************
+
+[excerpt from autoconf documentation]
+
+   The configuration scripts that Autoconf produces are covered by the
+GNU General Public License.  This is because they consist almost
+entirely of parts of Autoconf itself, rearranged somewhat, and Autoconf
+is distributed under the terms of the GPL.  As applied to Autoconf, the
+GPL just means that you need to distribute `configure.in' along with
+`configure'.
+
+   Programs that use Autoconf scripts to configure themselves do not
+automatically come under the GPL.  Distributing an Autoconf
+configuration script as part of a program is considered to be *mere
+aggregation* of that work with the Autoconf script.  Such programs are
+not derivative works based on Autoconf; only their configuration scripts
+are.  We still encourage software authors to distribute their work under
+terms like those of the GPL, but doing so is not required to use
+Autoconf.
diff --git a/INSTALL b/INSTALL
new file mode 100644
index 0000000..a85fdbb
--- /dev/null
+++ b/INSTALL
@@ -0,0 +1,120 @@
+   This is a generic INSTALL file for utilities distributions.
+If this package does not come with, e.g., installable documentation or
+data files, please ignore the references to them below.
+
+   [For information specific to Scheme 48, see doc/install.txt.]
+
+   The `configure' shell script attempts to guess correct values for
+various system-dependent variables used during compilation, and
+creates the Makefile(s) (one in each subdirectory of the source
+directory).  In some packages it creates a C header file containing
+system-dependent definitions.  It also creates a file `config.status'
+that you can run in the future to recreate the current configuration.
+
+To compile this package:
+
+1.  Configure the package for your system.
+
+   Normally, you just `cd' to the directory containing the package's
+source code and type `./configure'.  If you're using `csh' on an old
+version of System V, you might need to type `sh configure' instead to
+prevent `csh' from trying to execute `configure' itself.
+
+   Running `configure' takes a minute or two.  While it is running, it
+prints some messages that tell what it is doing.  If you don't want to
+see the messages, run `configure' with its standard output redirected
+to `/dev/null'; for example, `./configure >/dev/null'.
+
+   To compile the package in a different directory from the one
+containing the source code, you must use a version of `make' that
+supports the `VPATH' variable, such as GNU `make'.  `cd' to the
+directory where you want the object files and executables to go and run
+the `configure' script.  `configure' automatically checks for the
+source code in the directory that `configure' is in and in `..'.  If
+for some reason `configure' is not in the source code directory that
+you are configuring, then it will report that it can't find the source
+code.  In that case, run `configure' with the option `--srcdir=DIR',
+where DIR is the directory that contains the source code.
+
+   By default, `make install' will install the package's files in
+`/usr/local/bin', `/usr/local/man', etc.  You can specify an
+installation prefix other than `/usr/local' by giving `configure' the
+option `--prefix=PATH'.  Alternately, you can do so by consistently
+giving a value for the `prefix' variable when you run `make', e.g.,
+     make prefix=/usr/gnu
+     make prefix=/usr/gnu install
+
+   You can specify separate installation prefixes for
+architecture-specific files and architecture-independent files.  If you
+give `configure' the option `--exec-prefix=PATH' or set the `make'
+variable `exec_prefix' to PATH, the package will use PATH as the prefix
+for installing programs and libraries.  Data files and documentation
+will still use the regular prefix.  Normally, all files are installed
+using the same prefix.
+
+   Some packages pay attention to `--with-PACKAGE' options to
+`configure', where PACKAGE is something like `gnu-as' or `x' (for the X
+Window System).  The README should mention any `--with-' options that
+the package recognizes.
+
+   `configure' ignores any other arguments that you give it.
+
+   On systems that require unusual options for compilation or linking
+that the package's `configure' script does not know about, you can give
+`configure' initial values for variables by setting them in the
+environment.  In Bourne-compatible shells, you can do that on the
+command line like this:
+
+     CC='gcc -traditional' LIBS=-lposix ./configure
+
+   Here are the `make' variables that you might want to override with
+environment variables when running `configure'.
+
+   For these variables, any value given in the environment overrides the
+value that `configure' would choose:
+
+ - Variable: CC
+     C compiler program.  The default is `cc'.
+
+ - Variable: INSTALL
+     Program to use to install files.  The default is `install' if you
+     have it, `cp' otherwise.
+
+   For these variables, any value given in the environment is added to
+the value that `configure' chooses:
+
+ - Variable: DEFS
+     Configuration options, in the form `-Dfoo -Dbar...'.  Do not use
+     this variable in packages that create a configuration header file.
+
+ - Variable: LIBS
+     Libraries to link with, in the form `-lfoo -lbar...'.
+
+   If you need to do unusual things to compile the package, we encourage
+you to figure out how `configure' could check whether to do them, and
+mail diffs or instructions to the address given in the README so we
+can include them in the next release.
+
+2.  Type `make' to compile the package.  If you want, you can override
+the `make' variables CFLAGS and LDFLAGS like this:
+
+	make CFLAGS=-O2 LDFLAGS=-s
+
+3.  If the package comes with self-tests and you want to run them,
+type `make check'.  If you're not sure whether there are any, try it;
+if `make' responds with something like
+	make: *** No way to make target `check'.  Stop.
+then the package does not come with self-tests.
+
+4.  Type `make install' to install programs, data files, and
+documentation.
+
+5.  You can remove the program binaries and object files from the
+source directory by typing `make clean'.  To also remove the
+Makefile(s), the header file containing system-dependent definitions
+(if the package uses one), and `config.status' (all the files that
+`configure' created), type `make distclean'.
+
+   The file `configure.in' is used to create `configure' by a program
+called `autoconf'.  You only need it if you want to regenerate
+`configure' using a newer version of `autoconf'.
diff --git a/Makefile.in b/Makefile.in
new file mode 100644
index 0000000..bfdd82c
--- /dev/null
+++ b/Makefile.in
@@ -0,0 +1,535 @@
+# Scheme 48 Makefile
+# Documentation in files INSTALL and doc/install.txt
+
+SHELL = /bin/sh
+
+### Filled in by `configure' ###
+srcdir = @srcdir@
+VPATH = @srcdir@
+CC = @CC@
+DEFS = @DEFS@
+LIBS = @LIBS@
+CFLAGS = @CFLAGS@
+INSTALL = @INSTALL@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_DATA = @INSTALL_DATA@
+
+LDFLAGS = @LDFLAGS@
+LIBOBJS = @LIBOBJS@
+
+prefix = @prefix@
+exec_prefix = @exec_prefix@
+### End of `configure' section###
+
+bindir = $(exec_prefix)/bin
+libdir = $(exec_prefix)/lib
+incdir = $(exec_prefix)/include
+manext = 1
+mandir = $(prefix)/man/man$(manext)
+
+# HP 9000 series, if you don't have gcc
+#   CC = cc
+#   CFLAGS = -Aa -O +Obb1800
+#   DEFS = -D_HPUX_SOURCE -Dhpux
+
+# Ultrix
+#   LDFLAGS = -N
+
+.c.o:
+	$(CC) -c $(CPPFLAGS) $(DEFS) -I$(srcdir)/c $(CFLAGS) -o $@ $<
+
+# You might want to change RUNNABLE to "s48"
+RUNNABLE = scheme48
+MANPAGE = $(RUNNABLE).$(manext)
+LIB = $(libdir)/$(RUNNABLE)
+
+distdir = /tmp
+
+# If make barfs on this include line, just comment it out.  It's only
+# really needed if you want to build the linker or rebuild initial.image.
+include $(srcdir)/build/filenames.make
+#
+#NetBSD make wants to see this instead:
+#.include "$(srcdir)/build/filenames.make"
+
+
+# Static linker:
+#
+# You only need the linker if you're going to make changes to the
+# things that go into the initial.image, which in general means the
+# files in rts/.  If you decide you need to use the linker, then you
+# gots your choice; it can run in just about any version of Scheme 48
+# or Pseudoscheme.  (It has also been made to run in Scheme->C.)  It
+# doesn't matter a whole lot which Scheme you use as long as it's not
+# broken or unavailable.  The two best choices are:
+# 1. As below: build the linker on the scheme48vm and scheme48.image
+#    that are in the current directory.
+# 2. LINKER_VM = $(RUNNABLE) $(BIG_HEAP)
+#    LINKER_RUNNABLE = $(RUNNABLE)
+#    These settings requires you to already have a $(RUNNABLE)
+#    command.  This is desirable if you are making changes to the
+#    system that might break scheme48vm and/or scheme48.image.  But it
+#    requires you to have squirreled away a previous working version
+#    of scheme48.
+
+BIG_HEAP = -h 5000000
+LINKER_VM = ./$(VM) $(BIG_HEAP)
+LINKER_RUNNABLE = $(LINKER_VM) -i $(IMAGE)
+LINKER_IMAGE = build/linker.image
+LINKER = $(LINKER_VM) -i $(LINKER_IMAGE)
+START_LINKER = echo ',batch' && echo ',bench on'
+
+# --------------------
+# You shouldn't have to change anything below this point, except for possibly
+# the external code rules.
+
+# Targets:
+
+IMAGE = scheme48.image
+INITIAL = build/initial.image
+VM = scheme48vm
+UNIX_OBJS = c/unix/misc.o c/unix/io.o c/unix/fd-io.o c/unix/event.o
+OBJS = c/scheme48vm.o c/scheme48heap.o c/extension.o c/external.o
+FAKEHS	= c/fake/dlfcn.h c/fake/sigact.h c/fake/strerror.h \
+		c/fake/sys-select.h
+
+# Sources:
+
+CONFIG_FILES = scheme/interfaces.scm scheme/low-packages.scm \
+	       scheme/rts-packages.scm scheme/comp-packages.scm
+
+# Rules:
+
+# The following is the first rule and therefore the "make" command's
+# default target.
+enough: $(VM) $(IMAGE) go .notify
+
+# --------------------
+# External code to include in the VM
+# After changing any of these you should delete `scheme48vm' and remake it.
+
+EXTERNAL_OBJECTS = $(SOCKET_OBJECTS) $(LOOKUP_OBJECTS)
+EXTERNAL_FLAGS = $(SOCKET_FLAGS)
+EXTERNAL_INITIALIZERS = $(SOCKET_INITIALIZERS) $(LOOKUP_INITIALIZERS)
+
+# Rules for any external code.
+
+# Socket rules
+
+c/unix/socket.o: c/scheme48.h c/fd-io.h c/event.h
+
+SOCKET_OBJECTS = c/unix/socket.o
+SOCKET_LD_FLAGS =
+SOCKET_INITIALIZERS = 	s48_init_socket
+
+# End of socket rules
+
+# Lookup rules (this is just for compatibility with old code)
+
+c/unix/dynamo.o: c/scheme48.h
+
+LOOKUP_OBJECTS = c/unix/dynamo.o
+LOOKUP_INITIALIZERS = 	s48_init_external_lookup
+
+# End of lookup rules
+# End of external rules
+# --------------------
+
+# The developers are curious to know.  Don't be concerned if this fails.
+.notify: build/minor-version-number
+	touch .notify
+	-echo Another 0.`cat $(srcdir)/build/minor-version-number` \
+		installation. \
+		| mail scheme-48-notifications@martigny.ai.mit.edu
+
+$(VM): c/main.o $(OBJS) $(UNIX_OBJS) $(LIBOBJS) $(EXTERNAL_OBJECTS)
+	rm -f /tmp/s48_external_$$$$.c &&					\
+	build/build-external-modules /tmp/s48_external_$$$$.c			\
+		$(EXTERNAL_INITIALIZERS) &&					\
+	$(CC) $(LDFLAGS) $(CFLAGS) -o $@ c/main.o $(OBJS) $(UNIX_OBJS)		\
+		/tmp/s48_external_$$$$.c					\
+		$(LIBOBJS) $(LIBS)						\
+		$(EXTERNAL_OBJECTS) $(EXTERNAL_LD_FLAGS) &&			\
+	rm -f /tmp/s48_external_$$$$.c
+
+c/main.o: c/main.c c/scheme48vm.h c/scheme48heap.h
+	$(CC) -c $(CFLAGS) -o $@ \
+		-DDEFAULT_IMAGE_NAME=\"$(LIB)/$(IMAGE)\" \
+		$(CPPFLAGS) $(DEFS) c/main.c
+
+c/scheme48vm.o: c/prescheme.h c/scheme48vm.h c/scheme48heap.h c/event.h \
+			c/io.h c/fd-io.h c/scheme48vm-prelude.h
+c/scheme48heap.o: c/prescheme.h c/scheme48vm.h c/scheme48heap.h c/event.h \
+			c/io.h c/fd-io.h
+c/extension.o: c/sysdep.h $(FAKEHS) c/scheme48.h c/scheme48vm.h
+c/external.o: c/sysdep.h $(FAKEHS) c/scheme48.h
+c/unix/event.o: c/sysdep.h $(FAKEHS) c/scheme48vm.h c/scheme48heap.h \
+			c/event.h c/fd-io.h
+c/unix/fd-io.o: c/sysdep.h $(FAKEHS) c/scheme48vm.h c/scheme48heap.h \
+			c/event.h c/fd-io.h
+c/unix/misc.o: c/sysdep.h $(FAKEHS)
+c/unix/io.o: c/io.h
+c/fake/libdl1.o: c/fake/dlfcn.h
+c/fake/libdl2.o: c/fake/dlfcn.h
+c/fake/strerror.o: c/fake/strerror.h
+
+# --------------------
+# Make scheme48.image from initial.image and library .scm files.
+#
+# For bootstrap reasons, initial.image is *not* listed as a source,
+# even though it really is.
+
+$(IMAGE): $(VM) scheme/env/init-defpackage.scm scheme/more-interfaces.scm \
+		scheme/link-packages.scm scheme/more-packages.scm \
+		$(usual-files) build/initial.debug build/build-usual-image
+	build/build-usual-image . "`pwd`/scheme" '$(IMAGE)' './$(VM)' \
+		'$(INITIAL)'
+
+### Fake targets:  all clean install man dist
+
+install: enough dirs inst-script inst-vm inst-misc inst-man inst-inc inst-image
+
+inst-vm:
+	$(INSTALL_PROGRAM) $(VM) $(LIB)
+
+inst-image:
+	rm -f '/tmp/$(IMAGE)' &&					\
+	build/build-usual-image . '$(LIB)' '/tmp/$(IMAGE)' './$(VM)'	\
+		'$(INITIAL)' &&						\
+	$(INSTALL_DATA) /tmp/$(IMAGE) $(LIB) &&				\
+	rm /tmp/$(IMAGE)
+
+inst-man:
+	if [ -d $(mandir) -a -w $(mandir) ]; then			   \
+		sed 's=LBIN=$(bindir)=g' doc/scheme48.man |		   \
+			sed 's=LLIB=$(LIB)=g' |				   \
+			sed 's=LS48=$(RUNNABLE)=g' >$(MANPAGE) &&	   \
+		$(INSTALL_DATA) $(MANPAGE) $(mandir) &&			   \
+		rm $(MANPAGE);						   \
+	else								   \
+		echo "$(mandir) not writable dir, not installing man page" \
+			>&2;						   \
+	fi
+
+inst-inc:
+	$(INSTALL_DATA) c/scheme48.h $(incdir)
+
+inst-misc:
+	for stub in env big opt misc link; do				\
+		for f in scheme/$$stub/*.scm; do			\
+			$(INSTALL_DATA) $$f $(LIB)/$$stub || exit 1;	\
+		done;							\
+	done &&								\
+	for f in scheme/rts/*num.scm scheme/rts/jar-defrecord.scm; do	\
+		$(INSTALL_DATA) $$f $(LIB)/rts || exit 1;		\
+	done
+
+inst-script:
+	script=$(bindir)/$(RUNNABLE) &&					\
+	echo '#!/bin/sh'	>$$script &&				\
+	echo			>>$$script &&				\
+	echo 'lib=$(LIB)'	>>$$script &&				\
+	echo 'exec $$lib/$(VM) -o $$lib/$(VM) -i $$lib/$(IMAGE) "$$@"'	\
+				>>$$script &&				\
+	chmod +x $$script
+
+# Script to run scheme48 in this directory.
+go:
+	echo '#!/bin/sh'	>$@ &&					\
+	echo			>>$@ &&					\
+	echo "lib=`pwd`"	>>$@ &&					\
+	echo 'exec $$lib/$(VM) -o $$lib/$(VM) -i $$lib/$(IMAGE) "$$@"'	\
+				>>$@ &&					\
+	chmod +x $@
+
+dirs:
+	for dir in $(libdir) $(bindir) $(incdir); do			 \
+		[ -d $$dir -a -w $$dir ] || {				 \
+			echo "$$dir not a writable directory" >&2;	 \
+			exit 1;						 \
+		};							 \
+	done
+	{ mkdir -p $(LIB) && [ -w $(LIB) ]; } || {			 \
+		echo "$(LIB) not a writable directory" >&2;		 \
+		exit 1;							 \
+	}
+	for dir in rts env big opt misc link; do			  \
+		{ mkdir -p $(LIB)/$$dir && [ -w $(LIB)/$$dir ]; } || {	  \
+			echo "$(LIB)/$$dir not a writable directory" >&2; \
+			exit 1;						  \
+		};							  \
+	done
+
+configure: configure.in
+	autoheader && autoconf
+
+clean:
+	-rm -f $(VM) *.o c/unix/*.o c/*.o c/fake/*.o			\
+		TAGS $(IMAGE)						\
+		build/*.tmp $(MANPAGE) build/linker.image		\
+		scheme/debug/*.image scheme/debug/*.debug config.cache	\
+		scheme/vm/scheme48vm.c scheme/vm/scheme48heap.c		\
+		go $(distname)
+
+distclean: clean
+	rm -f Makefile config.log config.status c/sysdep.h
+
+check:	$(VM) $(IMAGE) scheme/debug/check.scm
+	(								\
+		echo ',batch';						\
+		echo ',translate =scheme48 scheme';			\
+		echo ',config ,load scheme/debug/test.scm';		\
+		echo ',exec ,load scheme/debug/check.scm';		\
+		echo ',exec (done)'					\
+	) | ./$(VM) -i $(IMAGE)
+
+# --------------------
+# Rules from here on down are not essential for the basic installation
+# procedure, and are not expected to work when srcdir is not the
+# distribution directory.
+
+all: vm linker
+	$(MAKE) image
+vm: $(VM)
+linker: $(LINKER_IMAGE)
+image: $(INITIAL)
+	$(MAKE) $(IMAGE)
+
+tags:
+	etags scheme/vm/arch.scm scheme/rts/*.scm scheme/bcomp/*.scm \
+	scheme/*.scm scheme/env/*.scm scheme/big/*.scm scheme/link/*.scm \
+	scheme/opt/*.scm scheme/debug/*.scm scheme/misc/*.scm
+
+# --------------------
+# Distribution...
+
+# DISTFILES should include all sources.
+DISTFILES = README COPYING INSTALL configure				\
+		acconfig.h configure.in Makefile.in install-sh		\
+		doc/*.ps doc/*.txt doc/html/*.html doc/scheme48.man	\
+		doc/src/*.tex doc/src/*.sty				\
+		emacs/README build/*-version-number build/*.exec	\
+		build/*.lisp build/build-usual-image build/filenames.make \
+		build/filenames.scm build/initial.debug			\
+		build/initial.image build/initial.scm			\
+		build/build-external-modules				\
+		c/*.[ch] c/*/*.[ch] c/scheme48.h.in			\
+		emacs/*.el gdbinit					\
+		scheme/*.scm scheme/*/*.scm				\
+		ps-compiler						\
+		c/sysdep.h.in
+
+distname = $(RUNNABLE)-0.`cat build/minor-version-number`
+
+dist: build/initial.image
+	distname=$(distname) &&						\
+	distfile=$(distdir)/$$distname.tgz &&				\
+	if [ -d $(distdir) ] &&						\
+	   [ -w $$distfile -o -w $(distdir) ]; then			\
+		rm -f $$distname &&					\
+		ln -s . $$distname &&					\
+		files='' &&						\
+		for i in $(DISTFILES); do				\
+			if [ "$$i" != "c/sysdep.h" ]; then		\
+				files="$$files $$distname/$$i";		\
+			fi						\
+		done &&							\
+		tar -cf - $$files |					\
+			gzip --best >$$distfile &&			\
+		rm $$distname;						\
+	else								\
+		echo "Can't write $$distfile" >&2;			\
+		exit 1;							\
+	fi
+
+# Increment the minor version number
+inc:
+	f=build/minor-version-number &&					\
+	expr `cat $$f` + 1 >$$f.tmp &&					\
+	mv $$f.tmp $$f &&						\
+	echo '(define version-info "0.'`cat $$f`'")'			\
+		>scheme/env/version-info.scm
+
+
+# --------------------
+# Generate build/filenames.make from *packages.scm
+#
+# This hack traces the module dependencies described in the
+# various configuration files and converts them into dependency lists
+# that "make" can use for its purposes.
+#
+# Since the distribution comes with a filenames.make, this rule
+# shouldn't be invoked for simple installations.  But it will be used
+# if you change any of the *-packages.scm files.
+#
+# You can actually run the forms in filenames.scm in any Scheme
+# implementation that has syntax-rules and explicit-renaming low-level
+# macros (e.g., most versions of Scheme 48 and Pseudoscheme).
+# If there are errors running this script, and you need to debug,
+# don't use the initial.image, use something that has a reasonable
+# environment.
+#
+# If this fails and you don't feel like debugging or fixing the problem,
+# try "touch filenames.make" and hope for the best.
+
+PACKAGES=scheme/packages.scm scheme/rts-packages.scm scheme/alt-packages.scm \
+	 scheme/comp-packages.scm scheme/initial-packages.scm \
+	 scheme/link-packages.scm scheme/more-packages.scm \
+	 build/filenames.scm
+
+build/filenames.make: $(PACKAGES)
+	$(MAKE) $(VM) PACKAGES=
+	./$(VM) -i $(srcdir)/$(INITIAL) -a batch <build/filenames.scm
+# or:	$(RUNNABLE) -a batch <build/filenames.scm
+
+# --------------------
+# Static linker
+#
+# The linker is capable of rebuilding an image from sources, even
+# across an incompatible change in VM data representations.
+
+build/linker.image: $(linker-files) scheme/alt/init-defpackage.scm
+	(echo ',batch';						\
+		echo ',bench on';				\
+		echo ',open signals handle features';		\
+		echo ',open bitwise ascii code-vectors record';	\
+		echo ',load $(linker-files)';			\
+		echo ',load scheme/alt/init-defpackage.scm';	\
+		echo ',dump build/linker.image'			\
+	) | $(LINKER_RUNNABLE)
+
+# Or, to bootstrap from Lucid Common Lisp: (last tested with
+# Pseudoscheme 2.9 and Scheme 48 version 0.19)
+
+PSEUDODIR = ../pseudo
+
+link/linker-in-lucid: build/lucid-script.lisp $(linker-files) \
+	    scheme/alt/pseudoscheme-features.scm \
+	    scheme/alt/pseudoscheme-record.scm
+	(echo \(defvar pseudoscheme-directory \"$(PSEUDODIR)/\"\); \
+	 cat build/lucid-script.lisp; \
+	 echo \(dump-linker\) \(lcl:quit\)) \
+	| lisp
+
+# --------------------
+# Initial image
+#
+# The initial.image is built by the static linker.  The image contains
+# Scheme, the byte-code compiler, and a minimal command processor, but
+# no debugging environment to speak of.
+
+$(INITIAL): $(LINKER_IMAGE) $(CONFIG_FILES) build/initial.scm $(initial-files)
+	($(START_LINKER);						\
+		echo '(load-configuration "scheme/interfaces.scm")';	\
+		echo '(load-configuration "scheme/packages.scm")';	\
+		echo '(flatload initial-structures)';			\
+		echo '(load "build/initial.scm")';			\
+		echo '(link-initial-system)'				\
+	) | $(LINKER)
+
+# --------------------
+# Various small images for debugging low-level changes
+
+LOAD_DEBUG = \
+	 $(START_LINKER); \
+	 echo \(load-configuration \"scheme/interfaces.scm\"\); \
+	 echo \(load-configuration \"scheme/packages.scm\"\); \
+	 echo \(flatload debug-structures\)
+
+scheme/debug/tiny.image: $(LINKER_IMAGE) scheme/debug/tiny-packages.scm \
+		  scheme/debug/tiny.scm
+	($(START_LINKER); \
+	 echo \(load-configuration \"scheme/debug/tiny-packages.scm\"\); \
+	 echo \(link-simple-system \'\(scheme/debug tiny\) \'start tiny-system\)) \
+	| $(LINKER)
+
+scheme/debug/low-test.image: $(LINKER_IMAGE) scheme/debug/low-test-packages.scm \
+		  scheme/debug/low-test.scm
+	($(START_LINKER); \
+	 echo \(load-configuration \"scheme/debug/low-test-packages.scm\"\); \
+	 echo \(link-simple-system \'\(scheme/debug low-test\) \'start low-test-system\)) \
+	| $(LINKER)
+
+scheme/debug/little.image: $(LINKER_IMAGE) $(CONFIG_FILES) scheme/debug-packages.scm
+	($(LOAD_DEBUG); echo \(link-little-system\)) \
+	| time $(LINKER)
+
+scheme/debug/mini.image: $(LINKER_IMAGE) $(CONFIG_FILES)
+	($(LOAD_DEBUG); echo \(link-mini-system\)) \
+	| $(LINKER)
+
+scheme/debug/medium.image: $(LINKER_IMAGE) $(CONFIG_FILES)
+	($(LOAD_DEBUG); echo \(flatload compiler-structures\); \
+	 echo \(link-medium-system\)) \
+	| $(LINKER)
+
+# The following have not been updated for the new directory organization
+
+c/smain.o: c/main.c
+	$(CC) -c $(CPPFLAGS) $(DEFS) $(CFLAGS) -DSTATIC_AREAS -o $@ c/main.c
+
+mini: mini-heap.o smain.o
+	$(CC) $(LDFLAGS) $(CFLAGS) -o $@ c/smain.o mini-heap.o $(OBJS) $(LIBS)
+
+mini-heap.o: mini-heap.c
+	$(CC) -c $(CPPFLAGS) $(DEFS) $(CFLAGS) -o $@ $(srcdir)/mini-heap.c
+
+mini-heap.c: scheme/debug/mini1.image
+	(echo ,exec ,load misc/load-static.scm; \
+	 echo \(do-it 150000 \"$(srcdir)/scheme/debug/mini1.image\" \"$@\"\)) \
+	| $(RUNNABLE) -h 3000000 -a batch
+
+scheme/debug/mini1.image: $(VM) scheme/debug/mini.image
+	echo "(write-image \"scheme/debug/mini1.image\" \
+			   (usual-resumer (lambda (args) \
+					    (command-processor #f args))) \
+			   \"foo\")" \
+	| ./$(VM) -i scheme/debug/mini.image -a batch
+
+
+# --------------------
+# Generate scheme48.h from VM sources
+
+c/scheme48.h: c/scheme48.h.in scheme/vm/arch.scm scheme/vm/data.scm \
+	    scheme/link/generate-c-header.scm
+	(echo ',bench';								\
+		echo ',batch';							\
+		echo ',load-package big-scheme';				\
+		echo ',open big-scheme';					\
+		echo ',load scheme/link/generate-c-header.scm';			\
+		echo "(make-c-header-file \"$@\"				\
+					  \"$(srcdir)/c/scheme48.h.in\"		\
+					  \"$(srcdir)/scheme/vm/arch.scm\"	\
+					  \"$(srcdir)/scheme/vm/data.scm\"   	\
+					  \"$(srcdir)/scheme/rts/record.scm\")"	\
+	) | $(RUNNABLE)
+
+# An old version of the above for legacy code.
+
+c/old-scheme48.h: scheme/vm/arch.scm scheme/vm/data.scm \
+	    scheme/link/generate-old-c-header.scm
+	(echo ',bench';								\
+		echo ',batch';							\
+		echo ',load-package big-scheme';				\
+		echo ',open big-scheme';					\
+		echo ',load scheme/link/generate-old-c-header.scm';		\
+		echo "(make-c-header-file \"$@\"				\
+					  \"$(srcdir)/scheme/vm/arch.scm\"	\
+					  \"$(srcdir)/scheme/vm/data.scm\")"   	\
+	) | $(RUNNABLE)
+
+# Generate vm (scheme48vm.c and scheme48heap.c) from VM sources.
+# Never called automatically.  Do not use unless you are sure you
+# know what you are doing.
+# Afterwards, you should probably make c/scheme48.h.
+i-know-what-i-am-doing:
+	cd ps-compiler &&						     \
+	(echo ',batch';							     \
+		echo ',config ,load ../scheme/prescheme/interface.scm';	     \
+		echo ',config ,load ../scheme/prescheme/package-defs.scm';   \
+		echo ',exec ,load load-ps-compiler.scm';		     \
+		echo ',exec ,load compile-vm-no-gc.scm';		     \
+		echo ',exec ,load compile-gc.scm';			     \
+		echo ',exit'						     \
+	) | $(RUNNABLE) -h 8000000 &&					     \
+		mv ../scheme/vm/scheme48vm.c ../scheme/vm/scheme48heap.c ../c
diff --git a/README b/README
new file mode 100644
index 0000000..68a4b86
--- /dev/null
+++ b/README
@@ -0,0 +1,93 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+Please report bugs to scheme-48-bugs@martigny.ai.mit.edu, and include
+the version number in your message.
+
+Installation instructions in file INSTALL.
+
+A user's guide is in file doc/user-guide.txt.
+
+Recent changes are listed in file doc/news.txt.
+
+Known bugs and things to do in the future are listed in doc/todo.txt.
+
+Send mail to scheme-48-request@martigny.ai.mit.edu to be put on a
+mailing list for announcements, discussion, bug reports, and bug
+fixes.
+
+-----
+
+When running "make", don't worry if the ".notify" target fails.  Its
+only purpose is to send an email message to
+scheme-48-notifications@martigny.ai.mit.edu, so that we can get a
+rough idea of how much Scheme 48 is being used and by whom.  We
+promise not to use your name or email address for any commercial
+purpose.  If you don't want us to know, just do "make -t .notify"
+first (after running "configure").
+     
+-----
+
+The Scheme 48 root directory is organized as follows (not all files are
+listed here):
+
+    README		this file
+    INSTALL		installation instructions
+    COPYING		copyright notice
+    configure		configuration script
+    Makefile.in		input to configure
+    doc/		some documentation
+      scheme48.man	a Unix-style manual page
+      user-guide.txt	general guide to using Scheme 48
+      todo.txt		list of improvements we hope to make someday
+      news.txt		list of improvements we have already made
+      module.ps		description of Scheme 48's module system
+      big-scheme.txt	extensions to Scheme
+      threads.txt	multiprocessing
+      io.txt		how the I/O system works
+    scheme/		scheme source files
+      packages.scm	meta-module definitions
+      interfaces.scm	system interface definitions
+      more-interfaces.scm system interface definitions
+      *-packages.scm	module definitions
+      bcomp/		the byte-code compiler
+      vm/		virtual machine sources (written in Pre-Scheme)
+      rts/		run-time system sources
+      link/		static linker
+      env/		development environment modules (debugger, etc.)
+      big/		useful Scheme libraries and extensions ("Big Scheme")
+      alt/		portable implementations of some Scheme 48 features
+      opt/		optional code optimizer for the byte-code compiler
+      prescheme/	code for running the VM using Scheme 48
+      debug/		debugging utilities, tests, etc.
+      misc/		very miscellaneous things (e.g. AMB operator)
+      posix/		unfinished interface to POSIX system calls
+    ps-compiler/	Pre-Scheme -> C compiler
+    c/			c source files
+      sysdep.h.in	input to configure
+      scheme48vm.c	most of the VM (generated by Pre-Scheme compiler)
+      scheme48vm.h	extern declarations for scheme48vm.c
+      scheme48heap.c    storage management (generated by Pre-Scheme compiler)
+      scheme48heap.h	extern declarations for scheme48heap.c
+      main.c		entry point for the VM
+      prescheme.h	part of the VM
+      extension.c       default definition of vm_extension()
+      scheme48.h	C declarations and macros for Scheme 48 data structures
+      old-scheme48.h	old version, included for compatibility
+      c-mods.h		minor additions to the C language
+      event.h		header file for OS interface
+      io.h		ditto
+      fd-io.h		ditto
+      socket.c		socket support
+      dynamo.c		dynamic loading support
+      unix/             Unix-specific source files
+      posix/		C half of an unfinished interface to POSIX system calls
+      fake/		C files for insufficiently POSIX-compliant systems
+    build/		code for building the system
+      filenames.make	included by Makefile, generated automatically
+      filenames.scm	code for generating filenames.make
+      initial.image	an image file containing a minimal Scheme system
+      initial.debug	debugging database for same
+      initial.scm	script for creating initial.image
+      build-usual-image	script for creating scheme48.image
+      build-external-modules script for creating external-module initializer
+    emacs/		gnu emacs support
diff --git a/acconfig.h b/acconfig.h
new file mode 100644
index 0000000..ece5e70
--- /dev/null
+++ b/acconfig.h
@@ -0,0 +1,32 @@
+/*
+ * HAVE_SIGACTION is defined iff sigaction() is available.
+ */
+#undef	HAVE_SIGACTION
+
+/*
+ * HAVE_STRERROR is defined iff the standard libraries provide strerror().
+ */
+#undef	HAVE_STRERROR
+
+/*
+ * NLIST_HAS_N_NAME is defined iff a struct nlist has an n_name member.
+ * If it doesn't then we assume it has an n_un member which, in turn,
+ * has an n_name member.
+ */
+#undef	NLIST_HAS_N_NAME
+
+/*
+ * HAVE_SYS_SELECT_H is defined iff we have the include file sys/select.h.
+ */
+#undef	HAVE_SYS_SELECT_H
+
+/*
+ * USCORE is defined iff C externals are prepended with an underscore.
+ */
+#undef	USCORE
+
+@BOTTOM@
+
+#include "fake/sigact.h"
+#include "fake/strerror.h"
+#include "fake/sys-select.h"
diff --git a/build/build-external-modules b/build/build-external-modules
new file mode 100755
index 0000000..aad9f2f
--- /dev/null
+++ b/build/build-external-modules
@@ -0,0 +1,28 @@
+#!/bin/sh
+# Build external-modules.c.
+
+target="$1"
+shift
+
+(
+	cat <<!
+
+!
+	for i in "s48_initialize_external" "$@"; do
+		cat <<!
+extern void	$i(void);
+!
+	done
+	cat <<!
+
+void s48_initialize_external_modules (void) {
+!
+	for i in "s48_initialize_external" "$@"; do
+		cat <<!
+			$i();
+!
+	done
+	cat <<!
+		};
+!
+) >"$target"
diff --git a/build/build-usual-image b/build/build-usual-image
new file mode 100755
index 0000000..ea3f23e
--- /dev/null
+++ b/build/build-usual-image
@@ -0,0 +1,33 @@
+#!/bin/sh
+# Build the usual development environment image.
+
+date=`date`
+srcdir=$1
+lib=$2
+image=$3
+vm=$4
+initial=$5
+USER=${USER-`logname 2>/dev/null || echo '*GOK*'`}
+
+$vm -i $initial -a batch <<EOF
+,load $srcdir/scheme/env/init-defpackage.scm
+((*structure-ref filenames 'set-translation!)
+ "=scheme48/" "$srcdir/scheme/")
+,load =scheme48/more-interfaces.scm =scheme48/link-packages.scm
+,load =scheme48/more-packages.scm
+(ensure-loaded command-processor)
+(ensure-loaded usual-commands)
+,go ((*structure-ref command 'command-processor)
+     (structure-package usual-commands)
+     (list "batch"))
+(ensure-loaded usual-features)
+,structure more-structures more-structures-interface
+,in debuginfo (read-debug-info "$srcdir/build/initial.debug")
+,keep maps source files
+,translate =scheme48/ $lib/
+,build ((*structure-ref package-commands-internal
+			'new-command-processor)
+	"(made by $USER on $date)"
+	usual-commands
+	built-in-structures more-structures) $image
+EOF
diff --git a/build/filenames.make b/build/filenames.make
new file mode 100644
index 0000000..71e0cee
--- /dev/null
+++ b/build/filenames.make
@@ -0,0 +1,7 @@
+#### This file was generated automatically. ####
+
+initial-files = scheme/rts/low.scm scheme/rts/signal.scm scheme/rts/base.scm scheme/rts/util.scm scheme/rts/number.scm scheme/rts/lize.scm scheme/rts/record.scm scheme/rts/jar-defrecord.scm scheme/rts/method.scm scheme/rts/numio.scm scheme/rts/fluid.scm scheme/rts/defenum.scm scheme/vm/arch.scm scheme/big/queue.scm scheme/rts/condition.scm scheme/rts/session.scm scheme/rts/interrupt.scm scheme/rts/wind.scm scheme/rts/template.scm scheme/rts/continuation.scm scheme/rts/exception.scm scheme/rts/thread.scm scheme/rts/sleep.scm scheme/rts/lock.scm scheme/rts/port.scm scheme/rts/current-port.scm scheme/rts/write.scm scheme/rts/read.scm scheme/rts/channel.scm scheme/rts/channel-port.scm scheme/rts/channel-io.scm scheme/big/general-table.scm scheme/rts/population.scm scheme/bcomp/mtype.scm scheme/bcomp/interface.scm scheme/bcomp/binding.scm scheme/bcomp/name.scm scheme/bcomp/transform.scm scheme/bcomp/cenv.scm scheme/bcomp/thingie.scm scheme/bcomp/package.scm scheme/bcomp/package-undef.scm scheme/rts/env.scm scheme/big/filename.scm scheme/bcomp/read-form.scm scheme/bcomp/node.scm scheme/bcomp/schemify.scm scheme/bcomp/var-util.scm scheme/bcomp/syntax.scm scheme/bcomp/primop.scm scheme/bcomp/ddata.scm scheme/bcomp/stack-check.scm scheme/bcomp/state.scm scheme/bcomp/segment.scm scheme/bcomp/recon.scm scheme/bcomp/comp-exp.scm scheme/bcomp/comp-prim.scm scheme/bcomp/comp.scm scheme/rts/eval.scm scheme/env/dispcond.scm scheme/debug/mini-command.scm scheme/rts/scheduler.scm scheme/rts/root-scheduler.scm scheme/rts/init.scm scheme/env/start.scm scheme/bcomp/usual.scm scheme/bcomp/rules.scm scheme/bcomp/type.scm scheme/bcomp/module-language.scm scheme/bcomp/config.scm scheme/bcomp/scan-package.scm scheme/bcomp/optimize.scm scheme/bcomp/comp-package.scm scheme/env/load-package.scm scheme/big/strong.scm scheme/opt/usage.scm scheme/opt/sort.scm scheme/opt/inline.scm scheme/bcomp/for-reify.scm 
+
+usual-files = scheme/opt/analyze.scm scheme/env/disclosers.scm scheme/env/command-level.scm scheme/env/version-info.scm scheme/env/command.scm scheme/env/read-command.scm scheme/env/debuginfo.scm scheme/rts/xnum.scm scheme/rts/bignum.scm scheme/rts/ratnum.scm scheme/rts/recnum.scm scheme/rts/innum.scm scheme/env/basic-command.scm scheme/env/build.scm scheme/env/shadow.scm scheme/env/pedit.scm scheme/env/pacman.scm scheme/rts/time.scm scheme/env/debug.scm scheme/env/inspect.scm scheme/env/disasm.scm 
+
+linker-files = scheme/rts/util.scm scheme/alt/fluid.scm scheme/rts/defenum.scm scheme/vm/arch.scm scheme/alt/jar-defrecord.scm scheme/big/general-table.scm scheme/bcomp/mtype.scm scheme/alt/locations.scm scheme/bcomp/binding.scm scheme/bcomp/name.scm scheme/bcomp/transform.scm scheme/bcomp/node.scm scheme/bcomp/schemify.scm scheme/bcomp/var-util.scm scheme/bcomp/primop.scm scheme/alt/template.scm scheme/rts/template.scm scheme/bcomp/ddata.scm scheme/bcomp/thingie.scm scheme/bcomp/stack-check.scm scheme/bcomp/state.scm scheme/bcomp/segment.scm scheme/bcomp/recon.scm scheme/bcomp/comp-exp.scm scheme/bcomp/comp-prim.scm scheme/bcomp/comp.scm scheme/alt/closure.scm scheme/link/data.scm scheme/link/transport.scm scheme/link/write-image.scm scheme/alt/weak.scm scheme/rts/population.scm scheme/bcomp/interface.scm scheme/bcomp/cenv.scm scheme/bcomp/package.scm scheme/bcomp/package-undef.scm scheme/bcomp/syntax.scm scheme/env/debuginfo.scm scheme/big/filename.scm scheme/bcomp/read-form.scm scheme/bcomp/scan-package.scm scheme/bcomp/optimize.scm scheme/bcomp/usual.scm scheme/bcomp/rules.scm scheme/bcomp/comp-package.scm scheme/big/strong.scm scheme/opt/usage.scm scheme/opt/sort.scm scheme/opt/inline.scm scheme/link/reify.scm scheme/link/link.scm scheme/alt/loophole.scm scheme/bcomp/type.scm scheme/alt/low.scm scheme/bcomp/module-language.scm scheme/bcomp/config.scm scheme/opt/analyze.scm scheme/alt/environments.scm scheme/link/loadc.scm scheme/env/flatload.scm 
diff --git a/build/filenames.scm b/build/filenames.scm
new file mode 100644
index 0000000..5473313
--- /dev/null
+++ b/build/filenames.scm
@@ -0,0 +1,47 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Generate filenames.make from *-packages.scm.
+
+
+; Define DEFINE-STRUCTURE and friends
+(for-each load
+	  '("scheme/bcomp/module-language.scm"
+	    "scheme/alt/config.scm"
+	    "scheme/env/flatload.scm"))
+
+(load-configuration "scheme/packages.scm")  
+
+; The following defines are unnecessary; they only serve to suppress
+; annoying "undefined" warnings for some forward references.
+(define methods 0) 
+(define tables 0) 
+
+(flatload linker-structures)		 
+
+(define q-f (all-file-names link-config)) 
+
+; (display "Initial structures") (newline)
+(flatload initial-structures)
+
+(define scheme (make-scheme environments evaluation))
+
+(define initial-system
+  (structure (export)
+    (open ;; Cf. initial.scm
+	  (make-initial-system scheme (make-mini-command scheme))
+	  module-system
+	  ensures-loaded
+	  for-reification))) ;foo...
+
+(define i-f (all-file-names initial-system))
+
+; (display "Usual structures") (newline)
+(flatload usual-structures)
+
+(define u-f (all-file-names usual-features initial-system))
+
+(write-file-names "build/filenames.make"      
+		  'initial-files i-f
+		  'usual-files u-f
+		  'linker-files q-f)
+
diff --git a/build/initial.debug b/build/initial.debug
new file mode 100644
index 0000000..94b5f0b
--- /dev/null
+++ b/build/initial.debug
@@ -0,0 +1,6351 @@
+; Package uid -> name
+(0 low-structures)
+(1 debug-low-structures)
+(2 alt-features-structures)
+(3 cheat-features-structures)
+(4 the-interfaces)
+(5 meta-module-system)
+(6 run-time-structures)
+(7 compiler-structures)
+(8 initial-structures)
+(9 debug-structures)
+(10 usual-structures)
+(11 alt-low-structures)
+(12 compiler-structures)
+(13 linker-structures)
+(14 scheme-level-0)
+(15 scheme-level-1)
+(16 records)
+(17 export-the-record-type)
+(18 define-record-types)
+(19 methods)
+(20 number-i/o)
+(21 fluids)
+(22 wind)
+(23 session-data)
+(24 i/o)
+(25 channels)
+(26 channel-i/o)
+(27 conditions)
+(28 writing)
+(29 reading)
+(30 scheme-level-2)
+(31 features)
+(32 templates)
+(33 continuations)
+(34 more-types)
+(35 enumerated)
+(36 architecture)
+(37 exceptions)
+(38 interrupts)
+(39 threads)
+(40 scheduler)
+(41 root-scheduler)
+(42 enum-case)
+(43 queues)
+(44 locks)
+(45 usual-resumer)
+(46 weak)
+(47 display-conditions)
+(48 meta-types)
+(49 bindings)
+(50 names)
+(51 thingies)
+(52 nodes)
+(53 compiler-envs)
+(54 syntactic)
+(55 usual-macros)
+(56 var-utilities)
+(57 debug-data)
+(58 stack-check)
+(59 segments)
+(60 primops)
+(61 reconstruction)
+(62 compiler)
+(63 reading-forms)
+(64 flat-environments)
+(65 interfaces)
+(66 packages)
+(67 scan-package)
+(68 optimizer)
+(69 compile-packages)
+(70 defpackage)
+(71 types)
+(72 module-system)
+(73 usages)
+(74 analysis)
+(75 inline)
+(76 strong)
+(77 tables)
+(78 filenames)
+(79 environments)
+(80 evaluation)
+(81 ensures-loaded)
+(82 for-reification)
+(83 scheme)
+(84 mini-command)
+(85 initial-system)
+-
+; Location uid -> (name . package-uid)
+(0 (and . 14))
+(1 (cond . 14))
+(2 (do . 14))
+(3 (let . 14))
+(4 (let* . 14))
+(5 (or . 14))
+(6 (code-quote . 14))
+(7 (quote . 14))
+(8 (unspecific . 14))
+(9 (define-syntax . 14))
+(10 (lambda . 14))
+(11 (begin . 14))
+(12 (unassigned . 14))
+(13 (flat-lambda . 14))
+(14 (define . 14))
+(15 (primitive-procedure . 14))
+(16 (if . 14))
+(17 (letrec-syntax . 14))
+(18 (%file-name% . 14))
+(19 (let-syntax . 14))
+(20 (structure-ref . 14))
+(21 (loophole . 14))
+(22 (letrec . 14))
+(23 (lap . 14))
+(24 (set! . 14))
+(25 (call . 14))
+(26 (atan . 14))
+(27 (set-location-defined?! . 14))
+(28 (acos . 14))
+(29 (vm-extension . 14))
+(30 (asin . 14))
+(31 (location-defined? . 14))
+(32 (time . 14))
+(33 (template-set! . 14))
+(34 (cons . 14))
+(35 (wait . 14))
+(36 (trap . 14))
+(37 (assq . 14))
+(38 (make-weak-pointer . 14))
+(39 (lookup-shared-binding . 14))
+(40 (push . 14))
+(41 (set-contents! . 14))
+(42 (read-char . 14))
+(43 (make-cell . 14))
+(44 (sqrt . 14))
+(45 (* . 14))
+(46 (contents . 14))
+(47 (+ . 14))
+(48 (peek-char . 14))
+(49 (- . 14))
+(50 (continuation-set! . 14))
+(51 (/ . 14))
+(52 (weak-pointer? . 14))
+(53 (quotient . 14))
+(54 (close-channel . 14))
+(55 (channel-abort . 14))
+(56 (char? . 14))
+(57 (< . 14))
+(58 (= . 14))
+(59 (> . 14))
+(60 (make-location . 14))
+(61 (imag-part . 14))
+(62 (set-port-data! . 14))
+(63 (make-template . 14))
+(64 (real? . 14))
+(65 (real-part . 14))
+(66 (get-cont-from-heap . 14))
+(67 (record-length . 14))
+(68 (port-data . 14))
+(69 (pair? . 14))
+(70 (make-port . 14))
+(71 (set-port-lock! . 14))
+(72 (return-from-exception . 14))
+(73 (location? . 14))
+(74 (channel-maybe-read . 14))
+(75 (checked-record-ref . 14))
+(76 (add-finalizer! . 14))
+(77 (rational? . 14))
+(78 (template? . 14))
+(79 (port-lock . 14))
+(80 (vector-length . 14))
+(81 (make-continuation . 14))
+(82 (string-length . 14))
+(83 (shared-binding-ref . 14))
+(84 (port? . 14))
+(85 (angle . 14))
+(86 (false . 14))
+(87 (remainder . 14))
+(88 (continuation? . 14))
+(89 (binary-reduce1 . 14))
+(90 (binary-reduce2 . 14))
+(91 (char<? . 14))
+(92 (char=? . 14))
+(93 (<= . 14))
+(94 (magnitude . 14))
+(95 (>= . 14))
+(96 (with-continuation . 14))
+(97 (floor . 14))
+(98 (apply . 14))
+(99 (memory-status . 14))
+(100 (checked-record-set! . 14))
+(101 (inexact->exact . 14))
+(102 (exact->inexact . 14))
+(103 (error . 14))
+(104 (extended-number-length . 14))
+(105 (open-channels-list . 14))
+(106 (channel-id . 14))
+(107 (shared-binding-set! . 14))
+(108 (numerator . 14))
+(109 (eof-object . 14))
+(110 (byte-vector-length . 14))
+(111 (record-ref . 14))
+(112 (make-polar . 14))
+(113 (write-char . 14))
+(114 (symbol->string . 14))
+(115 (exact? . 14))
+(116 (vector-ref . 14))
+(117 (set-current-thread! . 14))
+(118 (immutable? . 14))
+(119 (set-exception-handlers! . 14))
+(120 (string-ref . 14))
+(121 (set-port-index! . 14))
+(122 (make-shared-binding . 14))
+(123 (current-thread . 14))
+(124 (channel-status . 14))
+(125 (set-port-limit! . 14))
+(126 (shared-binding-name . 14))
+(127 (port-index . 14))
+(128 (make-immutable! . 14))
+(129 (set-enabled-interrupts! . 14))
+(130 (port-limit . 14))
+(131 (ascii->char . 14))
+(132 (char->ascii . 14))
+(133 (undefine-shared-binding . 14))
+(134 (record-set! . 14))
+(135 (shared-binding? . 14))
+(136 (eof-object? . 14))
+(137 (set-interrupt-handlers! . 14))
+(138 (record . 14))
+(139 (schedule-interrupt . 14))
+(140 (channel-maybe-write . 14))
+(141 (extended-number-ref . 14))
+(142 (vector-set! . 14))
+(143 (copy-bytes! . 14))
+(144 (string-set! . 14))
+(145 (call-external-value . 14))
+(146 (values . 14))
+(147 (intern . 14))
+(148 (vector . 14))
+(149 (byte-vector-ref . 14))
+(150 (make-double . 14))
+(151 (make-record . 14))
+(152 (set-location-id! . 14))
+(153 (location-id . 14))
+(154 (bitwise-and . 14))
+(155 (eq? . 14))
+(156 (write-image . 14))
+(157 (double? . 14))
+(158 (extended-number-set! . 14))
+(159 (make-vector . 14))
+(160 (record? . 14))
+(161 (make-string . 14))
+(162 (set-port-buffer! . 14))
+(163 (primitive-catch . 14))
+(164 (string-hash . 14))
+(165 (template-length . 14))
+(166 (number? . 14))
+(167 (port-buffer . 14))
+(168 (byte-vector-set! . 14))
+(169 (bitwise-ior . 14))
+(170 (set-car! . 14))
+(171 (closure-env . 14))
+(172 (vector? . 14))
+(173 (bitwise-not . 14))
+(174 (set-cdr! . 14))
+(175 (symbol? . 14))
+(176 (string? . 14))
+(177 (car . 14))
+(178 (bitwise-xor . 14))
+(179 (cdr . 14))
+(180 (find-all-records . 14))
+(181 (continuation-length . 14))
+(182 (log . 14))
+(183 (message . 14))
+(184 (tan . 14))
+(185 (collect . 14))
+(186 (cos . 14))
+(187 (channel-os-index . 14))
+(188 (make-extended-number . 14))
+(189 (set-port-status! . 14))
+(190 (sin . 14))
+(191 (exp . 14))
+(192 (pop . 14))
+(193 (port-status . 14))
+(194 (return-from-callback . 14))
+(195 (set-port-locked?! . 14))
+(196 (make-byte-vector . 14))
+(197 (weak-pointer-ref . 14))
+(198 (call-with-values . 14))
+(199 (denominator . 14))
+(200 (reverse-list->string . 14))
+(201 (port-locked? . 14))
+(202 (extended-number? . 14))
+(203 (shared-binding-is-import? . 14))
+(204 (find-all . 14))
+(205 (cell-ref . 14))
+(206 (byte-vector? . 14))
+(207 (string=? . 14))
+(208 (open-channel . 14))
+(209 (channel? . 14))
+(210 (make-rectangular . 14))
+(211 (set-session-data! . 14))
+(212 (template-ref . 14))
+(213 (make-closure . 14))
+(214 (session-data . 14))
+(215 (integer? . 14))
+(216 (signal-condition . 14))
+(217 (port-handler . 14))
+(218 (set-port-pending-eof?! . 14))
+(219 (define-shared-binding . 14))
+(220 (arithmetic-shift . 14))
+(221 (complex? . 14))
+(222 (port-pending-eof? . 14))
+(223 (cell-set! . 14))
+(224 (binary-comparison-reduce2 . 14))
+(225 (closure? . 14))
+(226 (continuation-ref . 14))
+(227 (closure-template . 14))
+(228 (current-cont . 14))
+(229 (char->integer . 14))
+(230 (integer->char . 14))
+(231 (ascii-limit . 14))
+(232 (ascii-whitespaces . 14))
+(233 (procedure? . 14))
+(234 (invoke-closure . 14))
+(235 (primitive-cwcc . 14))
+(236 (make-undefined-location . 14))
+(237 (location-assigned? . 14))
+(238 (vector-unassigned? . 14))
+(239 (string-copy . 14))
+(240 (string->symbol . 14))
+(241 (input-port? . 14))
+(242 (output-port? . 14))
+(243 (make-code-vector . 14))
+(244 (code-vector? . 14))
+(245 (code-vector-length . 14))
+(246 (code-vector-ref . 14))
+(247 (code-vector-set! . 14))
+(248 (channel-read . 14))
+(249 (buffer-length . 14))
+(250 (channel-write . 14))
+(251 (lookup-imported-binding . 14))
+(252 (lookup-exported-binding . 14))
+(253 (define-imported-binding . 14))
+(254 (define-exported-binding . 14))
+(255 (undefine-imported-binding . 14))
+(256 (undefine-exported-binding . 14))
+(257 (debug-message . 14))
+(258 (make-condition . 14))
+(259 (signal . 14))
+(260 (warn . 14))
+(261 (syntax-error . 14))
+(262 (call-error . 14))
+(263 (case . 15))
+(264 (quasiquote . 15))
+(265 (syntax-rules . 15))
+(266 (not . 15))
+(267 (boolean? . 15))
+(268 (eqv? . 15))
+(269 (equal? . 15))
+(270 (max . 15))
+(271 (min . 15))
+(272 (max-or-min . 15))
+(273 (abs . 15))
+(274 (zero? . 15))
+(275 (positive? . 15))
+(276 (negative? . 15))
+(277 (even? . 15))
+(278 (odd? . 15))
+(279 (caar . 15))
+(280 (cadr . 15))
+(281 (cdar . 15))
+(282 (cddr . 15))
+(283 (caaar . 15))
+(284 (caadr . 15))
+(285 (cadar . 15))
+(286 (caddr . 15))
+(287 (cdaar . 15))
+(288 (cdadr . 15))
+(289 (cddar . 15))
+(290 (cdddr . 15))
+(291 (caaaar . 15))
+(292 (caaadr . 15))
+(293 (caadar . 15))
+(294 (caaddr . 15))
+(295 (cadaar . 15))
+(296 (cadadr . 15))
+(297 (caddar . 15))
+(298 (cadddr . 15))
+(299 (cdaaar . 15))
+(300 (cdaadr . 15))
+(301 (cdadar . 15))
+(302 (cdaddr . 15))
+(303 (cddaar . 15))
+(304 (cddadr . 15))
+(305 (cdddar . 15))
+(306 (cddddr . 15))
+(307 (null? . 15))
+(308 (list . 15))
+(309 (length . 15))
+(310 (real-length . 15))
+(311 (append . 15))
+(312 (reverse . 15))
+(313 (append-reverse . 15))
+(314 (list-tail . 15))
+(315 (list-ref . 15))
+(316 (mem . 15))
+(317 (memq . 15))
+(318 (memv . 15))
+(319 (member . 15))
+(320 (ass . 15))
+(321 (assv . 15))
+(322 (assoc . 15))
+(323 (list? . 15))
+(324 (char>? . 15))
+(325 (char>=? . 15))
+(326 (char<=? . 15))
+(327 (char-whitespace? . 15))
+(328 (char-lower-case? . 15))
+(329 (char-upper-case? . 15))
+(330 (char-numeric? . 15))
+(331 (char-alphabetic? . 15))
+(332 (char-case-delta . 15))
+(333 (make-character-map . 15))
+(334 (upcase-map . 15))
+(335 (char-upcase . 15))
+(336 (downcase-map . 15))
+(337 (char-downcase . 15))
+(338 (char-ci-compare . 15))
+(339 (char-ci=? . 15))
+(340 (char-ci<? . 15))
+(341 (char-ci<=? . 15))
+(342 (char-ci>? . 15))
+(343 (char-ci>=? . 15))
+(344 (string . 15))
+(345 (substring . 15))
+(346 (string-append . 15))
+(347 (string->list . 15))
+(348 (list->string . 15))
+(349 (string-fill! . 15))
+(350 (make-string=? . 15))
+(351 (string-ci=? . 15))
+(352 (make-string<? . 15))
+(353 (string<? . 15))
+(354 (string-ci<? . 15))
+(355 (string>? . 15))
+(356 (string<=? . 15))
+(357 (string>=? . 15))
+(358 (string-ci>? . 15))
+(359 (string-ci<=? . 15))
+(360 (string-ci>=? . 15))
+(361 (vector->list . 15))
+(362 (list->vector . 15))
+(363 (vector-fill! . 15))
+(364 (map . 15))
+(365 (map1 . 15))
+(366 (map2+ . 15))
+(367 (for-each . 15))
+(368 (for-each1 . 15))
+(369 (for-each2+ . 15))
+(370 (delay . 15))
+(371 (make-promise . 15))
+(372 (force . 15))
+(373 (unspecific . 15))
+(374 (reduce . 15))
+(375 (filter . 15))
+(376 (pos . 15))
+(377 (posq . 15))
+(378 (posv . 15))
+(379 (position . 15))
+(380 (any . 15))
+(381 (every . 15))
+(382 (sublist . 15))
+(383 (last . 15))
+(384 (insert . 15))
+(385 (fold . 15))
+(386 (fold->2 . 15))
+(387 (fold->3 . 15))
+(388 (inexact? . 15))
+(389 (modulo . 15))
+(390 (ceiling . 15))
+(391 (truncate . 15))
+(392 (round . 15))
+(393 (gcd . 15))
+(394 (euclid . 15))
+(395 (lcm . 15))
+(396 (expt . 15))
+(397 (raise-to-integer-power . 15))
+(398 (rationalize . 15))
+(399 (simplest-rational . 15))
+(400 (record-type . 16))
+(401 (*record-type-uid* . 16))
+(402 (*record-type* . 16))
+(403 (make-record-type . 16))
+(404 (record-type? . 16))
+(405 (record-type-resumer . 16))
+(406 (set-record-type-resumer! . 16))
+(407 (record-type-uid . 16))
+(408 (record-type-name . 16))
+(409 (record-type-field-names . 16))
+(410 (record-type-number-of-fields . 16))
+(411 (record-type-discloser . 16))
+(412 (set-record-type-discloser! . 16))
+(413 (record-type-fields . 16))
+(414 (record-field-index . 16))
+(415 (record-constructor . 16))
+(416 (record-accessor . 16))
+(417 (record-modifier . 16))
+(418 (record-predicate . 16))
+(419 (define-record-discloser . 16))
+(420 (make-default-record-discloser . 16))
+(421 (disclose-record . 16))
+(422 (define-record-resumer . 16))
+(423 (default-record-resumer . 16))
+(424 (initialize-records! . 16))
+(425 (resume-record . 16))
+(426 (:record-type . 16))
+(427 (define-record-type . 18))
+(428 (define-constructor . 18))
+(429 (define-accessors . 18))
+(430 (define-accessor . 18))
+(431 (:simple-type . 19))
+(432 (really-make-simple-type . 19))
+(433 (simple-type-id . 19))
+(434 (simple-type-priority . 19))
+(435 (simple-type-predicate . 19))
+(436 (simple-type-superiors . 19))
+(437 (simple-type? . 19))
+(438 (make-simple-type . 19))
+(439 (compute-priority . 19))
+(440 (*increment* . 19))
+(441 (%type-priority . 19))
+(442 (%type-predicate . 19))
+(443 (%same-type? . 19))
+(444 (define-simple-type . 19))
+(445 (:syntax . 19))
+(446 (:values . 19))
+(447 (value? . 19))
+(448 (:value . 19))
+(449 (:zero . 19))
+(450 (:number . 19))
+(451 (:complex . 19))
+(452 (:real . 19))
+(453 (:rational . 19))
+(454 (:integer . 19))
+(455 (:exact-integer . 19))
+(456 (:boolean . 19))
+(457 (:symbol . 19))
+(458 (:char . 19))
+(459 (:null . 19))
+(460 (:pair . 19))
+(461 (:vector . 19))
+(462 (:string . 19))
+(463 (:procedure . 19))
+(464 (:input-port . 19))
+(465 (:output-port . 19))
+(466 (:eof-object . 19))
+(467 (:record . 19))
+(468 (record-type-priority . 19))
+(469 (:method-info . 19))
+(470 (really-make-method-info . 19))
+(471 (method-info-proc . 19))
+(472 (method-info-n-ary? . 19))
+(473 (method-info-types . 19))
+(474 (method-info? . 19))
+(475 (make-method-info . 19))
+(476 (empty-method-list . 19))
+(477 (insert-method . 19))
+(478 (same-applicability? . 19))
+(479 (every2 . 19))
+(480 (more-specific? . 19))
+(481 (more-specific-type? . 19))
+(482 (:method-table . 19))
+(483 (really-make-method-table . 19))
+(484 (method-table-id . 19))
+(485 (method-table-set-perform! . 19))
+(486 (method-table-get-perform . 19))
+(487 (make-generic . 19))
+(488 (method-table-prototype . 19))
+(489 (method-table-methods . 19))
+(490 (set-method-table-methods! . 19))
+(491 (method-table? . 19))
+(492 (make-method-table . 19))
+(493 (make-cell-for-generic . 19))
+(494 (add-to-method-table! . 19))
+(495 (set-final-method! . 19))
+(496 (apply-generic . 19))
+(497 (define-generic . 19))
+(498 (methods->perform . 19))
+(499 (last-action . 19))
+(500 (one-action . 19))
+(501 (argument-sequence-predicate . 19))
+(502 (check-for-next . 19))
+(503 (check-next . 19))
+(504 (method-info . 19))
+(505 (method-internal . 19))
+(506 (with-next-method . 19))
+(507 (define-method . 19))
+(508 (&add-method! . 19))
+(509 (add-method! . 19))
+(510 (&type-predicate . 19))
+(511 (type-predicate . 19))
+(512 (&type-priority . 19))
+(513 (type-priority . 19))
+(514 (&type-superiors . 19))
+(515 (type-superiors . 19))
+(516 (&same-type? . 19))
+(517 (same-type? . 19))
+(518 (:singleton . 19))
+(519 (singleton . 19))
+(520 (singleton-value . 19))
+(521 (compare-to . 19))
+(522 (&disclose . 19))
+(523 (disclose . 19))
+(524 (proc->discloser . 19))
+(525 (&number->string . 20))
+(526 (real-number->string . 20))
+(527 (number->string . 20))
+(528 (integer->string . 20))
+(529 (string->number . 20))
+(530 (&really-string->number . 20))
+(531 (really-string->number . 20))
+(532 (:integer-string . 20))
+(533 (set-exactness . 20))
+(534 (string->integer . 20))
+(535 (:thread . 21))
+(536 (make-thread . 21))
+(537 (thread-dynamic-point . 21))
+(538 (thread-dynamic-env . 21))
+(539 (get-dynamic-env . 21))
+(540 (set-dynamic-env! . 21))
+(541 (get-dynamic-point . 21))
+(542 (set-dynamic-point! . 21))
+(543 (initialize-dynamic-state! . 21))
+(544 (with-dynamic-env . 21))
+(545 (empty-dynamic-env . 21))
+(546 (:fluid . 21))
+(547 (make-fluid . 21))
+(548 (fluid-top-level-value . 21))
+(549 (set-fluid-top-level-value! . 21))
+(550 (fluid . 21))
+(551 (set-fluid! . 21))
+(552 (let-fluid . 21))
+(553 (let-fluids . 21))
+(554 (define-enumeration . 35))
+(555 (components . 35))
+(556 (enum . 35))
+(557 (enumerand->name . 35))
+(558 (name->enumerand . 35))
+(559 (lookup-enumerand . 35))
+(560 (architecture-version . 36))
+(561 (bits-used-per-byte . 36))
+(562 (byte-limit . 36))
+(563 (define-instruction-set . 36))
+(564 (op . 36))
+(565 (op-enumeration . 36))
+(566 (op-count . 36))
+(567 (opcode-arg-specs . 36))
+(568 (interrupt . 36))
+(569 (interrupt-enumeration . 36))
+(570 (interrupt-count . 36))
+(571 (exception . 36))
+(572 (exception-enumeration . 36))
+(573 (exception-count . 36))
+(574 (current-port-marker . 36))
+(575 (current-port-marker-enumeration . 36))
+(576 (current-port-marker-count . 36))
+(577 (maximum-stack-args . 36))
+(578 (*last-protocol* . 36))
+(579 (next-protocol . 36))
+(580 (two-byte-nargs-protocol . 36))
+(581 (two-byte-nargs+list-protocol . 36))
+(582 (big-stack-protocol . 36))
+(583 (args+nargs-protocol . 36))
+(584 (nary-dispatch-protocol . 36))
+(585 (maximum-external-call-args . 36))
+(586 (default-stack-space . 36))
+(587 (environment-stack-size . 36))
+(588 (continuation-stack-size . 36))
+(589 (available-stack-space . 36))
+(590 (time-option . 36))
+(591 (time-option-enumeration . 36))
+(592 (time-option-count . 36))
+(593 (memory-status-option . 36))
+(594 (memory-status-option-enumeration . 36))
+(595 (memory-status-option-count . 36))
+(596 (channel-status-option . 36))
+(597 (channel-status-option-enumeration . 36))
+(598 (channel-status-option-count . 36))
+(599 (port-status-options . 36))
+(600 (port-status-options-enumeration . 36))
+(601 (port-status-options-count . 36))
+(602 (stob . 36))
+(603 (stob-enumeration . 36))
+(604 (stob-count . 36))
+(605 (least-b-vector-type . 36))
+(606 (stob-data . 36))
+(607 (:queue . 43))
+(608 (really-make-queue . 43))
+(609 (queue-tail . 43))
+(610 (set-queue-tail! . 43))
+(611 (queue-head . 43))
+(612 (set-queue-head! . 43))
+(613 (queue-uid . 43))
+(614 (queue? . 43))
+(615 (*queue-uid* . 43))
+(616 (make-queue . 43))
+(617 (queue-empty? . 43))
+(618 (enqueue! . 43))
+(619 (queue-front . 43))
+(620 (dequeue! . 43))
+(621 (on-queue? . 43))
+(622 (delete-from-queue! . 43))
+(623 (delete-from-queue-if! . 43))
+(624 (queue->list . 43))
+(625 (queue-length . 43))
+(626 (*condition-types* . 27))
+(627 (condition-supertypes . 27))
+(628 (define-condition-type . 27))
+(629 (condition-predicate . 27))
+(630 (condition? . 27))
+(631 (condition-type . 27))
+(632 (condition-stuff . 27))
+(633 (error? . 27))
+(634 (call-error? . 27))
+(635 (read-error? . 27))
+(636 (exception? . 27))
+(637 (exception-opcode . 27))
+(638 (exception-reason . 27))
+(639 (exception-arguments . 27))
+(640 (make-exception . 27))
+(641 (warning? . 27))
+(642 (syntax-error? . 27))
+(643 (interrupt? . 27))
+(644 (*session-data-initializers* . 23))
+(645 (make-session-data-slot! . 23))
+(646 (session-data-ref . 23))
+(647 (session-data-set! . 23))
+(648 (initialize-session-data! . 23))
+(649 (initialize-interrupts! . 38))
+(650 (interrupt-handlers . 38))
+(651 (set-interrupt-handler! . 38))
+(652 (no-interrupts . 38))
+(653 (all-interrupts . 38))
+(654 (with-interrupts-inhibited . 38))
+(655 (with-interrupts-allowed . 38))
+(656 (disable-interrupts! . 38))
+(657 (enable-interrupts! . 38))
+(658 (with-interrupts . 38))
+(659 (enabled-interrupts . 38))
+(660 (*post-gc-procedures* . 38))
+(661 (call-after-gc! . 38))
+(662 (post-gc-handler . 38))
+(663 (required-post-gc-space . 38))
+(664 (space-shortage-handler . 38))
+(665 (call-before-heap-overflow! . 38))
+(666 (dynamic-wind . 22))
+(667 (call-with-current-continuation . 22))
+(668 (continuation->procedure . 22))
+(669 (:point . 22))
+(670 (make-point . 22))
+(671 (point-parent . 22))
+(672 (point-dynamic-env . 22))
+(673 (point-out . 22))
+(674 (point-in . 22))
+(675 (point-depth . 22))
+(676 (travel-to-point! . 22))
+(677 (template-overhead . 32))
+(678 (template-code . 32))
+(679 (template-info . 32))
+(680 (set-template-code! . 32))
+(681 (set-template-info! . 32))
+(682 (:closure . 34))
+(683 (:code-vector . 34))
+(684 (:location . 34))
+(685 (:template . 34))
+(686 (:channel . 34))
+(687 (:port . 34))
+(688 (:double . 34))
+(689 (:weak-pointer . 34))
+(690 (:shared-binding . 34))
+(691 (continuation-cont . 33))
+(692 (real-continuation-pc . 33))
+(693 (real-continuation-template . 33))
+(694 (continuation-env . 33))
+(695 (exception-continuation-pc . 33))
+(696 (exception-continuation-template . 33))
+(697 (exception-continuation-exception . 33))
+(698 (exception-continuation? . 33))
+(699 (continuation-pc . 33))
+(700 (continuation-template . 33))
+(701 (normal-continuation-overhead . 33))
+(702 (exception-continuation-overhead . 33))
+(703 (continuation-arg . 33))
+(704 (continuation-arg-count . 33))
+(705 (:continuation . 33))
+(706 (continuation-parent . 33))
+(707 (define-exception-handler . 37))
+(708 (signal-exception . 37))
+(709 (exception-handlers . 37))
+(710 (extend-opcode! . 37))
+(711 (really-signal-condition . 37))
+(712 (with-handler . 37))
+(713 ($condition-handlers . 37))
+(714 (initialize-exceptions! . 37))
+(715 (last-resort-condition-handler . 37))
+(716 (report-utter-lossage . 37))
+(717 (continuation-preview . 37))
+(718 (ignore-errors . 37))
+(719 (report-errors-as-warnings . 37))
+(720 (:thread . 39))
+(721 (really-make-thread . 39))
+(722 (thread-name . 39))
+(723 (thread-uid . 39))
+(724 (thread-current-task . 39))
+(725 (set-thread-current-task! . 39))
+(726 (thread-events . 39))
+(727 (set-thread-events! . 39))
+(728 (thread-data . 39))
+(729 (set-thread-data! . 39))
+(730 (thread-scheduler . 39))
+(731 (set-thread-scheduler! . 39))
+(732 (thread-time . 39))
+(733 (set-thread-time! . 39))
+(734 (thread-arguments . 39))
+(735 (set-thread-arguments! . 39))
+(736 (thread-queue . 39))
+(737 (set-thread-queue! . 39))
+(738 (thread-continuation . 39))
+(739 (set-thread-continuation! . 39))
+(740 (thread-dynamic-point . 39))
+(741 (set-thread-dynamic-point! . 39))
+(742 (thread-dynamic-env . 39))
+(743 (thread? . 39))
+(744 (*thread-uid* . 39))
+(745 (make-thread . 39))
+(746 (thread-top-level . 39))
+(747 (thread-uid->thread . 39))
+(748 (all-threads . 39))
+(749 (add-event! . 39))
+(750 (thunk->continuation . 39))
+(751 (compose-continuation . 39))
+(752 (make-thread-queue . 39))
+(753 (thread-queue-empty? . 39))
+(754 (enqueue-thread! . 39))
+(755 (dequeue-thread! . 39))
+(756 (remove-thread-from-queue! . 39))
+(757 (current-thread . 39))
+(758 (set-current-thread! . 39))
+(759 (event-type . 39))
+(760 (event-type-enumeration . 39))
+(761 (event-type-count . 39))
+(762 (run . 39))
+(763 (find-and-run-next-thread . 39))
+(764 (debit-thread-times-and-run! . 39))
+(765 (handle-timer-interrupt . 39))
+(766 (run-next-thread . 39))
+(767 (min . 39))
+(768 (switch-to-thread . 39))
+(769 (run-thread . 39))
+(770 (suspend . 39))
+(771 (suspend-to . 39))
+(772 (debit-down! . 39))
+(773 (exit . 39))
+(774 (wait . 39))
+(775 (waiting? . 39))
+(776 (block . 39))
+(777 (relinquish-timeslice . 39))
+(778 (upcall . 39))
+(779 (propogate-upcall . 39))
+(780 (kill-thread! . 39))
+(781 (interrupt-thread . 39))
+(782 (get-next-event! . 39))
+(783 (event-pending? . 39))
+(784 (schedule-event . 39))
+(785 (schedule-wakeup . 39))
+(786 (show-running . 39))
+(787 (running? . 39))
+(788 (spawn . 39))
+(789 (spawn-on-root . 39))
+(790 (spawn-on-scheduler . 39))
+(791 (make-ready . 39))
+(792 (schedule-interrupt! . 39))
+(793 (cancel-timer-interrupt! . 39))
+(794 (interrupt-timer-time . 39))
+(795 (real-time . 39))
+(796 (with-threads . 39))
+(797 (start-multitasking . 39))
+(798 (deadlock? . 39))
+(799 (terminate? . 39))
+(800 (terminate-current-thread . 39))
+(801 (root-scheduler-slot . 39))
+(802 (root-scheduler . 39))
+(803 (sleep . 39))
+(804 (*dozers* . 39))
+(805 (insert . 39))
+(806 (wake-some-threads . 39))
+(807 (:lock . 44))
+(808 (really-make-lock . 44))
+(809 (lock-uid . 44))
+(810 (lock-queue . 44))
+(811 (lock-owner-uid . 44))
+(812 (set-lock-owner-uid! . 44))
+(813 (lock? . 44))
+(814 (*lock-uid* . 44))
+(815 (make-lock . 44))
+(816 (obtain-lock . 44))
+(817 (maybe-obtain-lock . 44))
+(818 (release-lock . 44))
+(819 (:port-handler . 24))
+(820 (make-port-handler . 24))
+(821 (port-handler-buffer-proc . 24))
+(822 (port-handler-close . 24))
+(823 (port-handler-discloser . 24))
+(824 (port-handler? . 24))
+(825 (disclose-port . 24))
+(826 (obtain-port-lock . 24))
+(827 (maybe-obtain-port-lock . 24))
+(828 (release-port-lock . 24))
+(829 (initialize-i/o-handlers! . 24))
+(830 (one-arg-proc->handler . 24))
+(831 (two-arg-proc->handler . 24))
+(832 (read-char-handler . 24))
+(833 (fill-port-buffer! . 24))
+(834 (write-char-handler . 24))
+(835 (empty-port-buffer! . 24))
+(836 (port-flushed? . 24))
+(837 (set-port-flushed?! . 24))
+(838 (close-input-port . 24))
+(839 (close-output-port . 24))
+(840 (define-port-op . 24))
+(841 (real-char-ready? . 24))
+(842 (read-block . 24))
+(843 (really-read-block . 24))
+(844 (buffer-length . 24))
+(845 (read-more . 24))
+(846 (okay-limits? . 24))
+(847 (write-block . 24))
+(848 (write-string . 24))
+(849 (write-buffered-block . 24))
+(850 (write-unbuffered-block . 24))
+(851 (force-output . 24))
+(852 (really-force-output . 24))
+(853 (force-output-if-open . 24))
+(854 (default-buffer-size . 24))
+(855 (open-port? . 24))
+(856 (open-port-mask . 24))
+(857 (input-port-mask . 24))
+(858 (open-input-port-mask . 24))
+(859 (open-input-port-status . 24))
+(860 (open-input-port? . 24))
+(861 (make-input-port-closed! . 24))
+(862 (make-input-port . 24))
+(863 (okay-buffer? . 24))
+(864 (output-port-mask . 24))
+(865 (open-output-port-mask . 24))
+(866 (open-output-port-status . 24))
+(867 (open-output-port? . 24))
+(868 (make-output-port-closed! . 24))
+(869 (make-output-port . 24))
+(870 (make-unbuffered-output-port . 24))
+(871 (null-output-port-handler . 24))
+(872 (make-null-output-port . 24))
+(873 (*flush-these-ports* . 24))
+(874 (initialize-output-port-list! . 24))
+(875 (periodically-force-output! . 24))
+(876 (output-port-forcers . 24))
+(877 (periodically-flushed-ports . 24))
+(878 (make-forcing-thunk . 24))
+(879 ($current-input-port . 24))
+(880 ($current-output-port . 24))
+(881 ($current-error-port . 24))
+(882 ($current-noise-port . 24))
+(883 (current-input-port . 24))
+(884 (current-output-port . 24))
+(885 (current-error-port . 24))
+(886 (current-noise-port . 24))
+(887 (initialize-i/o . 24))
+(888 (with-current-ports . 24))
+(889 (call-with-current-input-port . 24))
+(890 (call-with-current-output-port . 24))
+(891 (call-with-current-noise-port . 24))
+(892 (silently . 24))
+(893 (newline . 24))
+(894 (char-ready? . 24))
+(895 (output-port-option . 24))
+(896 (input-port-option . 24))
+(897 (write . 28))
+(898 (recurring-write . 28))
+(899 (write-boolean . 28))
+(900 (write-number . 28))
+(901 (write-char-literal . 28))
+(902 (character-name . 28))
+(903 (write-string-literal . 28))
+(904 (write-list . 28))
+(905 (quotation? . 28))
+(906 (write-vector . 28))
+(907 (write-other . 28))
+(908 (display-type-name . 28))
+(909 (display . 28))
+(910 (read . 29))
+(911 (sub-read-carefully . 29))
+(912 (reader-token-marker . 29))
+(913 (make-reader-token . 29))
+(914 (reader-token? . 29))
+(915 (close-paren . 29))
+(916 (dot . 29))
+(917 (sub-read . 29))
+(918 (read-dispatch-vector . 29))
+(919 (read-terminating?-vector . 29))
+(920 (set-standard-syntax! . 29))
+(921 (set-standard-read-macro! . 29))
+(922 (sub-read-list . 29))
+(923 (gobble-line . 29))
+(924 (*sharp-macros* . 29))
+(925 (define-sharp-macro . 29))
+(926 (sub-read-token . 29))
+(927 (parse-token . 29))
+(928 (strange-symbol-names . 29))
+(929 (p-c-v . 29))
+(930 (preferred-case . 29))
+(931 (reading-error . 29))
+(932 (input-channel? . 25))
+(933 (output-channel? . 25))
+(934 (open-input-channel . 25))
+(935 (open-output-channel . 25))
+(936 (close-input-channel . 25))
+(937 (close-output-channel . 25))
+(938 (input-channel-handler . 26))
+(939 (input-channel->port . 26))
+(940 (input-channel+closer->port . 26))
+(941 (real-input-channel->port . 26))
+(942 (output-channel-handler . 26))
+(943 (make-unbuffered-output-channel-handler . 26))
+(944 (output-channel->port . 26))
+(945 (output-channel+closer->port . 26))
+(946 (real-output-channel->port . 26))
+(947 (maybe-force-output . 26))
+(948 (:channel-cell . 26))
+(949 (make-channel-cell . 26))
+(950 (channel-cell-closer . 26))
+(951 (channel-cell-ref . 26))
+(952 (channel-cell? . 26))
+(953 (port->channel . 26))
+(954 (open-input-file . 26))
+(955 (open-output-file . 26))
+(956 (call-with-input-file . 26))
+(957 (call-with-output-file . 26))
+(958 (with-input-from-file . 26))
+(959 (with-output-to-file . 26))
+(960 (force-channel-output-ports! . 26))
+(961 (steal-channel-port! . 26))
+(962 (really-steal-channel-port! . 26))
+(963 (initialize-channel-i/o! . 26))
+(964 (i/o-completion-handler . 26))
+(965 (waiting-for-i/o? . 26))
+(966 (wait-for-channel . 26))
+(967 (nothing . 26))
+(968 (steal-channel! . 26))
+(969 (channel-wait-count-slot . 26))
+(970 (channel-wait-count . 26))
+(971 (increment-channel-wait-count! . 26))
+(972 (decrement-channel-wait-count! . 26))
+(973 (channel-wait-queues-slot . 26))
+(974 (add-channel-wait-queue! . 26))
+(975 (fetch-channel-wait-queue! . 26))
+(976 (:table . 77))
+(977 (really-make-table . 77))
+(978 (table-set!-procedure . 77))
+(979 (set-table-set!-procedure! . 77))
+(980 (table-ref-procedure . 77))
+(981 (set-table-ref-procedure! . 77))
+(982 (table-data . 77))
+(983 (set-table-data! . 77))
+(984 (table-size . 77))
+(985 (set-table-size! . 77))
+(986 (table? . 77))
+(987 (table-ref . 77))
+(988 (table-set! . 77))
+(989 (linear-table-size-limit . 77))
+(990 (next-table-size . 77))
+(991 (make-table-maker . 77))
+(992 (assoc->table-maker . 77))
+(993 (null-entry . 77))
+(994 (new-entry . 77))
+(995 (entry-value . 77))
+(996 (entry-key . 77))
+(997 (set-entry-value! . 77))
+(998 (delete-entry! . 77))
+(999 (make-assoc . 77))
+(1000 (make-linear-table-ref . 77))
+(1001 (make-linear-table-set! . 77))
+(1002 (make->hash-table . 77))
+(1003 (make-hash-table-ref . 77))
+(1004 (make-hash-table-set! . 77))
+(1005 (expand-hash-table! . 77))
+(1006 (table-enter-alist! . 77))
+(1007 (table-expand-table! . 77))
+(1008 (table-walk . 77))
+(1009 (really-table-walk . 77))
+(1010 (alist-walk . 77))
+(1011 (make-table-immutable! . 77))
+(1012 (table->entry-list . 77))
+(1013 (default-table-hash-function . 77))
+(1014 (eqv?-assoc . 77))
+(1015 (default-table-assoc . 77))
+(1016 (symbol-hash . 77))
+(1017 (make-table . 77))
+(1018 (make-string-table . 77))
+(1019 (make-symbol-table . 77))
+(1020 (make-integer-table . 77))
+(1021 (make-population . 46))
+(1022 (add-to-population! . 46))
+(1023 (weak-memq . 46))
+(1024 (population-reduce . 46))
+(1025 (population->list . 46))
+(1026 (walk-population . 46))
+(1027 (:meta-type . 48))
+(1028 (really-make-type . 48))
+(1029 (type-info . 48))
+(1030 (type-more . 48))
+(1031 (type-mask . 48))
+(1032 (meta-type? . 48))
+(1033 (make-type . 48))
+(1034 (name->type-table . 48))
+(1035 (mask->name-table . 48))
+(1036 (name->type . 48))
+(1037 (set-type-name! . 48))
+(1038 (*mask* . 48))
+(1039 (new-type-bit . 48))
+(1040 (mask->type . 48))
+(1041 (bottom-type . 48))
+(1042 (error-type . 48))
+(1043 (bottom-type? . 48))
+(1044 (new-atomic-type . 48))
+(1045 (named-atomic-type . 48))
+(1046 (syntax-type . 48))
+(1047 (other-static-type . 48))
+(1048 (empty-rail-type . 48))
+(1049 (rail-type . 48))
+(1050 (make-optional-type . 48))
+(1051 (make-rest-type . 48))
+(1052 (head-type . 48))
+(1053 (head-type-really . 48))
+(1054 (tail-type . 48))
+(1055 (empty-rail-type? . 48))
+(1056 (rest-type? . 48))
+(1057 (optional-type? . 48))
+(1058 (mask/no-values . 48))
+(1059 (mask/two-or-more . 48))
+(1060 (mask/&rest . 48))
+(1061 (value-type . 48))
+(1062 (mask/value . 48))
+(1063 (value-type? . 48))
+(1064 (any-values-type . 48))
+(1065 (any-arguments-type . 48))
+(1066 (mask/one-or-more . 48))
+(1067 (same-type? . 48))
+(1068 (subtype? . 48))
+(1069 (meet-type . 48))
+(1070 (other-type-info . 48))
+(1071 (meet-rail . 48))
+(1072 (meet-procedure . 48))
+(1073 (meet? . 48))
+(1074 (meet-procedure? . 48))
+(1075 (join-type . 48))
+(1076 (join-rail . 48))
+(1077 (join-procedure . 48))
+(1078 (number-hierarchy . 48))
+(1079 (integer-type . 48))
+(1080 (rational-type . 48))
+(1081 (real-type . 48))
+(1082 (complex-type . 48))
+(1083 (number-type . 48))
+(1084 (exact-type . 48))
+(1085 (inexact-type . 48))
+(1086 (exact-integer-type . 48))
+(1087 (inexact-real-type . 48))
+(1088 (boolean-type . 48))
+(1089 (pair-type . 48))
+(1090 (null-type . 48))
+(1091 (record-type . 48))
+(1092 (any-procedure-type . 48))
+(1093 (other-value-type . 48))
+(1094 (mask/other . 48))
+(1095 (make-other-type . 48))
+(1096 (char-type . 48))
+(1097 (unspecific-type . 48))
+(1098 (string-type . 48))
+(1099 (symbol-type . 48))
+(1100 (vector-type . 48))
+(1101 (escape-type . 48))
+(1102 (structure-type . 48))
+(1103 (mask/procedure . 48))
+(1104 (procedure-type . 48))
+(1105 (make-procedure-type . 48))
+(1106 (procedure-type-domain . 48))
+(1107 (procedure-type-codomain . 48))
+(1108 (restrictive? . 48))
+(1109 (sexp->type . 48))
+(1110 (sexp->values-type . 48))
+(1111 (type->sexp . 48))
+(1112 (atomic-type->sexp . 48))
+(1113 (rail-type->sexp . 48))
+(1114 (disjoin-type . 48))
+(1115 (disjoin-rest . 48))
+(1116 (mask/number . 48))
+(1117 (make-some-values-type . 48))
+(1118 (proc . 48))
+(1119 (some-values . 48))
+(1120 (procedure-type? . 48))
+(1121 (fixed-arity-procedure-type? . 48))
+(1122 (procedure-type-arity . 48))
+(1123 (procedure-type-argument-types . 48))
+(1124 (variable-type . 48))
+(1125 (variable-type? . 48))
+(1126 (variable-value-type . 48))
+(1127 (usual-variable-type . 48))
+(1128 (undeclared-type . 48))
+(1129 (compatible-types? . 48))
+(1130 (:interface . 65))
+(1131 (really-make-interface . 65))
+(1132 (interface-name . 65))
+(1133 (set-interface-name! . 65))
+(1134 (interface-clients . 65))
+(1135 (walk-method . 65))
+(1136 (ref-method . 65))
+(1137 (interface? . 65))
+(1138 (interface-ref . 65))
+(1139 (for-each-declaration . 65))
+(1140 (note-reference-to-interface! . 65))
+(1141 (make-interface . 65))
+(1142 (make-simple-interface . 65))
+(1143 (really-make-simple-interface . 65))
+(1144 (make-compound-interface . 65))
+(1145 (note-interface-name! . 65))
+(1146 (binding? . 49))
+(1147 (binding-type . 49))
+(1148 (binding-place . 49))
+(1149 (binding-static . 49))
+(1150 (binding-path . 49))
+(1151 (set-binding-place! . 49))
+(1152 (make-binding . 49))
+(1153 (add-path . 49))
+(1154 (clobber-binding! . 49))
+(1155 (impose-type . 49))
+(1156 (forget-integration . 49))
+(1157 (same-denotation? . 49))
+(1158 (maybe-fix-place! . 49))
+(1159 (follow-forwarding-pointers . 49))
+(1160 (name? . 50))
+(1161 (:generated . 50))
+(1162 (make-generated . 50))
+(1163 (generated-parent-name . 50))
+(1164 (generated-env . 50))
+(1165 (generated-token . 50))
+(1166 (generated-symbol . 50))
+(1167 (generated? . 50))
+(1168 (generate-name . 50))
+(1169 (generated-uid . 50))
+(1170 (*generated-uid* . 50))
+(1171 (name->symbol . 50))
+(1172 (name-hash . 50))
+(1173 (make-name-table . 50))
+(1174 (desyntaxify . 50))
+(1175 (make-qualified . 50))
+(1176 (qualified? . 50))
+(1177 (qualified-parent-name . 50))
+(1178 (qualified-symbol . 50))
+(1179 (name->qualified . 50))
+(1180 (qualify-parent . 50))
+(1181 (:transform . 50))
+(1182 (really-make-transform . 50))
+(1183 (transform-id . 50))
+(1184 (transform-source . 50))
+(1185 (transform-aux-names . 50))
+(1186 (transform-type . 50))
+(1187 (transform-env . 50))
+(1188 (transform-procedure . 50))
+(1189 (transform? . 50))
+(1190 (make-transform . 50))
+(1191 (maybe-apply-macro-transform . 50))
+(1192 (apply-inline-transform . 50))
+(1193 (make-keyword-comparator . 50))
+(1194 (name->source-name . 50))
+(1195 (bind-aliases . 50))
+(1196 (make-name-generator . 50))
+(1197 (lookup . 50))
+(1198 (lookup . 53))
+(1199 (bind1 . 53))
+(1200 (bind . 53))
+(1201 (bindrec . 53))
+(1202 (make-compiler-env . 53))
+(1203 (funny-name/macro-eval . 53))
+(1204 (environment-macro-eval . 53))
+(1205 (funny-name/define! . 53))
+(1206 (environment-define! . 53))
+(1207 (funny-name/package . 53))
+(1208 (extract-package-from-environment . 53))
+(1209 (funny-name/source-file-name . 53))
+(1210 (bind-source-file-name . 53))
+(1211 (source-file-name . 53))
+(1212 (:thingie . 51))
+(1213 (make-thingie . 51))
+(1214 (thingie-want-type . 51))
+(1215 (thingie-name . 51))
+(1216 (thingie-binding . 51))
+(1217 (thingie? . 51))
+(1218 (:structure . 66))
+(1219 (really-make-structure . 66))
+(1220 (structure-name . 66))
+(1221 (set-structure-name! . 66))
+(1222 (structure-clients . 66))
+(1223 (structure-package . 66))
+(1224 (structure-interface-really . 66))
+(1225 (set-structure-interface! . 66))
+(1226 (structure-interface-thunk . 66))
+(1227 (structure? . 66))
+(1228 (structure-interface . 66))
+(1229 (initialize-structure! . 66))
+(1230 (make-structure . 66))
+(1231 (note-structure-name! . 66))
+(1232 (structure-unstable? . 66))
+(1233 (for-each-export . 66))
+(1234 (:package . 66))
+(1235 (really-make-package . 66))
+(1236 (package-cached . 66))
+(1237 (package-clients . 66))
+(1238 (package-real-undefined-but-assigneds . 66))
+(1239 (set-package-undefined-but-assigneds! . 66))
+(1240 (package-real-undefineds . 66))
+(1241 (set-package-undefineds! . 66))
+(1242 (package-accesses-thunk . 66))
+(1243 (package-opens-thunk . 66))
+(1244 (set-package-opens-thunk! . 66))
+(1245 (package->environment . 66))
+(1246 (set-package->environment! . 66))
+(1247 (package-loaded? . 66))
+(1248 (set-package-loaded?! . 66))
+(1249 (package-clauses . 66))
+(1250 (package-file-name . 66))
+(1251 (package-get-location . 66))
+(1252 (set-package-get-location! . 66))
+(1253 (package-integrate? . 66))
+(1254 (set-package-integrate?! . 66))
+(1255 (package-unstable? . 66))
+(1256 (package-definitions . 66))
+(1257 (package-opens-really . 66))
+(1258 (set-package-opens! . 66))
+(1259 (package-uid . 66))
+(1260 (package? . 66))
+(1261 (make-package . 66))
+(1262 (really-package->environment . 66))
+(1263 (lazy-table-accessor . 66))
+(1264 (package-undefineds . 66))
+(1265 (package-undefined-but-assigneds . 66))
+(1266 (new-package-uid . 66))
+(1267 (*package-uid* . 66))
+(1268 (package-name-table . 66))
+(1269 (package-name . 66))
+(1270 (note-package-name! . 66))
+(1271 (package-opens . 66))
+(1272 (initialize-package-if-necessary! . 66))
+(1273 (package-accesses . 66))
+(1274 (make-simple-package . 66))
+(1275 (package-definition . 66))
+(1276 (package-define! . 66))
+(1277 (package-add-static! . 66))
+(1278 (package-refine-type! . 66))
+(1279 (package-lookup . 66))
+(1280 (really-package-lookup . 66))
+(1281 (search-opens . 66))
+(1282 (structure-lookup . 66))
+(1283 (real-structure-lookup . 66))
+(1284 (generic-lookup . 66))
+(1285 (initialize-package! . 66))
+(1286 (for-each-definition . 66))
+(1287 (get-new-location . 66))
+(1288 (make-new-location . 66))
+(1289 ($get-location . 66))
+(1290 (*location-uid* . 66))
+(1291 (location-info-table . 66))
+(1292 (flush-location-names . 66))
+(1293 (link! . 66))
+(1294 (really-link! . 66))
+(1295 (get-location . 66))
+(1296 (location-on-demand . 66))
+(1297 (get-undefined . 66))
+(1298 (location-for-assignment . 66))
+(1299 (package-note-caching! . 66))
+(1300 (note-caching! . 66))
+(1301 (get-location-for-unassignable . 66))
+(1302 (get-location-for-undefined . 66))
+(1303 ($note-undefined . 66))
+(1304 (cenv->package . 66))
+(1305 (location-for-reference . 66))
+(1306 (noting-undefined-variables . 66))
+(1307 (print-undefined-names . 66))
+(1308 (environment-ref . 79))
+(1309 (environment-set! . 79))
+(1310 (environment-define! . 79))
+(1311 (*structure-ref . 79))
+(1312 (carefully . 79))
+(1313 ($interaction-environment . 79))
+(1314 (interaction-environment . 79))
+(1315 (set-interaction-environment! . 79))
+(1316 (with-interaction-environment . 79))
+(1317 (scheme-report-environment . 79))
+(1318 (*scheme-report-environment* . 79))
+(1319 (*null-environment* . 79))
+(1320 (*scheme-report-number* . 79))
+(1321 (set-scheme-report-environment! . 79))
+(1322 (null-environment . 79))
+(1323 (make-reflective-tower . 79))
+(1324 (set-reflective-tower-maker! . 79))
+(1325 (namestring . 78))
+(1326 (directory-component-separator . 78))
+(1327 (type-component-separator . 78))
+(1328 (namestring-component . 78))
+(1329 (file-name-preferred-case . 78))
+(1330 (*scheme-file-type* . 78))
+(1331 (*load-file-type* . 78))
+(1332 (file-name-directory . 78))
+(1333 (file-name-nondirectory . 78))
+(1334 (file-nondirectory-position . 78))
+(1335 (string-posq . 78))
+(1336 (*translations* . 78))
+(1337 (translations . 78))
+(1338 (set-translation! . 78))
+(1339 (translate . 78))
+(1340 ($note-file-package . 63))
+(1341 (read-forms . 63))
+(1342 (really-read-forms . 63))
+(1343 (:operator . 52))
+(1344 (make-operator . 52))
+(1345 (operator-name . 52))
+(1346 (operator-uid . 52))
+(1347 (operator-nargs . 52))
+(1348 (operator-type . 52))
+(1349 (set-operator-type! . 52))
+(1350 (operator? . 52))
+(1351 (usual-operator-type . 52))
+(1352 (get-operator . 52))
+(1353 (*operator-uid* . 52))
+(1354 (operators-table . 52))
+(1355 (number-of-operators . 52))
+(1356 (the-operators . 52))
+(1357 (make-operator-table . 52))
+(1358 (operator-table-ref . 52))
+(1359 (operator-lookup . 52))
+(1360 (operator-define! . 52))
+(1361 (:node . 52))
+(1362 (really-make-node . 52))
+(1363 (node-plist . 52))
+(1364 (set-node-plist! . 52))
+(1365 (node-form . 52))
+(1366 (node-operator-id . 52))
+(1367 (node? . 52))
+(1368 (make-node . 52))
+(1369 (node-ref . 52))
+(1370 (node-set! . 52))
+(1371 (node-operator . 52))
+(1372 (node-predicate . 52))
+(1373 (make-similar-node . 52))
+(1374 (force-node . 52))
+(1375 (schemify . 52))
+(1376 (schemifiers . 52))
+(1377 (schemify-node . 52))
+(1378 (schemify-nodes . 52))
+(1379 (define-schemifier . 52))
+(1380 (schemify-lambda . 52))
+(1381 (schemify-formals . 52))
+(1382 (schemify-sexp . 52))
+(1383 (number-of-required-args . 56))
+(1384 (n-ary? . 56))
+(1385 (normalize-formals . 56))
+(1386 (scan-forms . 54))
+(1387 (expand-scanned-form . 54))
+(1388 (scan-define . 54))
+(1389 (expand-define . 54))
+(1390 (scan-define-syntax . 54))
+(1391 (expand-form . 54))
+(1392 (expand-head . 54))
+(1393 (destructure-define . 54))
+(1394 (make-operator-predicate . 54))
+(1395 (define? . 54))
+(1396 (begin? . 54))
+(1397 (define-syntax? . 54))
+(1398 (static-value . 54))
+(1399 (expand-body . 54))
+(1400 (scan-body-forms . 54))
+(1401 (body-lossage . 54))
+(1402 (expand . 54))
+(1403 (expand-list . 54))
+(1404 (expand-literal . 54))
+(1405 (expand-call . 54))
+(1406 (expand-name . 54))
+(1407 (expand-macro-application . 54))
+(1408 (expand-operator-form . 54))
+(1409 (expanders . 54))
+(1410 (define-expander . 54))
+(1411 (unspecific-node . 54))
+(1412 (expand-structure-ref . 54))
+(1413 (expand-lambda . 54))
+(1414 (bind-names . 54))
+(1415 (names? . 54))
+(1416 (expand-letrec . 54))
+(1417 (process-syntax . 54))
+(1418 (this-long? . 54))
+(1419 (at-least-this-long? . 54))
+(1420 (specs? . 54))
+(1421 (literal? . 54))
+(1422 (syntax? . 54))
+(1423 (begin-node? . 54))
+(1424 (call-node? . 54))
+(1425 (name-node? . 54))
+(1426 (operator/literal . 54))
+(1427 (operator/quote . 54))
+(1428 (operator/call . 54))
+(1429 (operator/name . 54))
+(1430 (operator/unspecific . 54))
+(1431 (operator/unassigned . 54))
+(1432 (operator/lambda . 54))
+(1433 (operator/begin . 54))
+(1434 (operator/letrec . 54))
+(1435 (operator/define . 54))
+(1436 (operator/define-syntax . 54))
+(1437 (operator/primitive-procedure . 54))
+(1438 (operator/structure-ref . 54))
+(1439 (:primop . 60))
+(1440 (make-primop . 60))
+(1441 (primop-compilator . 60))
+(1442 (primop-closed . 60))
+(1443 (primop-type . 60))
+(1444 (primop-name . 60))
+(1445 (primop? . 60))
+(1446 (primop-table . 60))
+(1447 (walk-primops . 60))
+(1448 (define-compiler-primitive . 60))
+(1449 (get-primop . 60))
+(1450 (:debug-data . 57))
+(1451 (make-debug-data . 57))
+(1452 (debug-data-source . 57))
+(1453 (set-debug-data-source! . 57))
+(1454 (debug-data-env-maps . 57))
+(1455 (set-debug-data-env-maps! . 57))
+(1456 (debug-data-pc-in-parent . 57))
+(1457 (debug-data-parent . 57))
+(1458 (debug-data-name . 57))
+(1459 (debug-data-uid . 57))
+(1460 (debug-data? . 57))
+(1461 (maximum-stack-use . 58))
+(1462 (protocol-skip . 58))
+(1463 (stack-delta . 58))
+(1464 (define-delta . 58))
+(1465 (stack-max . 58))
+(1466 (nothing . 58))
+(1467 (popper . 58))
+(1468 (pusher . 58))
+(1469 (continue . 58))
+(1470 (continuer . 58))
+(1471 (do-make-cont . 58))
+(1472 (stack-function . 58))
+(1473 (arg-spec-size . 58))
+(1474 (imax . 58))
+(1475 (get-offset . 58))
+(1476 (new-template-uid . 59))
+(1477 (*template-uid* . 59))
+(1478 (template-uid . 59))
+(1479 (set-template-uid! . 59))
+(1480 (debug-flag-names . 59))
+(1481 (type/debug-flags . 59))
+(1482 (make-debug-flags . 59))
+(1483 ($debug-flags . 59))
+(1484 (debug-flag-accessor . 59))
+(1485 (debug-flag-modifier . 59))
+(1486 (keep-source-code? . 59))
+(1487 (keep-environment-maps? . 59))
+(1488 (keep-procedure-names? . 59))
+(1489 (keep-file-names? . 59))
+(1490 (tabulate-debug-data? . 59))
+(1491 (debug-data-table . 59))
+(1492 (with-fresh-compiler-state . 59))
+(1493 (saving-and-restoring . 59))
+(1494 (debug-data->info . 59))
+(1495 (get-debug-data . 59))
+(1496 (note-debug-data! . 59))
+(1497 (new-debug-data . 59))
+(1498 (make-segment . 59))
+(1499 (segment-size . 59))
+(1500 (segment-emitter . 59))
+(1501 (segment->template . 59))
+(1502 (segment-data->template . 59))
+(1503 (check-stack-use . 59))
+(1504 (:assembly-state . 59))
+(1505 (make-assembly-state . 59))
+(1506 (astate-literals . 59))
+(1507 (set-astate-literals! . 59))
+(1508 (astate-count . 59))
+(1509 (set-astate-count! . 59))
+(1510 (astate-pc . 59))
+(1511 (set-astate-pc! . 59))
+(1512 (astate-code-vector . 59))
+(1513 (make-astate . 59))
+(1514 (emit-byte! . 59))
+(1515 (literal->index . 59))
+(1516 (literal-position . 59))
+(1517 (position . 59))
+(1518 (emit-literal! . 59))
+(1519 (emit-segment! . 59))
+(1520 (empty-segment . 59))
+(1521 (instruction . 59))
+(1522 (sequentially . 59))
+(1523 (sequentially-2 . 59))
+(1524 (instruction-with-literal . 59))
+(1525 (instruction-with-location . 59))
+(1526 (template . 59))
+(1527 (make-label . 59))
+(1528 (instruction-using-label . 59))
+(1529 (computed-goto-label-size . 59))
+(1530 (computed-goto-instruction . 59))
+(1531 (attach-label . 59))
+(1532 (insert-label! . 59))
+(1533 (code-vector-set2! . 59))
+(1534 (two-byte-limit . 59))
+(1535 (high-byte . 59))
+(1536 (low-byte . 59))
+(1537 ($debug-data . 59))
+(1538 (note-source-code . 59))
+(1539 (note-environment . 59))
+(1540 (emit-with-environment-maps! . 59))
+(1541 ($environment-maps . 59))
+(1542 (node-type . 61))
+(1543 (reconstruct-type . 61))
+(1544 (reconstruct . 61))
+(1545 (examine . 61))
+(1546 (reconstructors . 61))
+(1547 (define-reconstructor . 61))
+(1548 (reconstruct-lambda . 61))
+(1549 (careful-codomain . 61))
+(1550 (reconstruct-name . 61))
+(1551 (proc->reconstructor . 61))
+(1552 (reconstruct-call . 61))
+(1553 (fork-constraints . 61))
+(1554 (node->type . 61))
+(1555 (name-node? . 61))
+(1556 (lambda-node? . 61))
+(1557 (literal-node? . 61))
+(1558 (primop-reconstructors . 61))
+(1559 (define-primop-reconstructor . 61))
+(1560 (reconstruct-apply . 61))
+(1561 (constant-type . 61))
+(1562 (compile-expression . 62))
+(1563 (compile . 62))
+(1564 (compilators . 62))
+(1565 (define-compilator . 62))
+(1566 (compile-constant . 62))
+(1567 (compile-call . 62))
+(1568 (compile-name-call . 62))
+(1569 (compile-redex . 62))
+(1570 (compile-unknown-call . 62))
+(1571 (maybe-push-continuation . 62))
+(1572 (fixup-source . 62))
+(1573 (push-arguments . 62))
+(1574 (push-all-with-names . 62))
+(1575 (compile-lambda . 62))
+(1576 (compile-lambda-code . 62))
+(1577 (name-node->symbol . 62))
+(1578 (set-lexical-offsets! . 62))
+(1579 (compile-flat-lambda . 62))
+(1580 (get-variables-offsets . 62))
+(1581 (variable-env-data . 62))
+(1582 (sort-list . 62))
+(1583 (make-cont . 62))
+(1584 (cont-segment . 62))
+(1585 (cont-source-info . 62))
+(1586 (return-cont-segment . 62))
+(1587 (return-cont . 62))
+(1588 (return-cont? . 62))
+(1589 (fall-through-cont . 62))
+(1590 (fall-through-cont? . 62))
+(1591 (ignore-values-segment . 62))
+(1592 (ignore-values-cont . 62))
+(1593 (ignore-values-cont? . 62))
+(1594 (deliver-value . 62))
+(1595 (named-cont . 62))
+(1596 (cont-name . 62))
+(1597 (name-node-binding . 62))
+(1598 (generate-trap . 62))
+(1599 (type-check . 62))
+(1600 (set-type-check?! . 62))
+(1601 (*type-check?* . 62))
+(1602 (diagnose-call-error . 62))
+(1603 (lambda-node? . 62))
+(1604 (name-node? . 62))
+(1605 (literal-node? . 62))
+(1606 (operator/lambda . 62))
+(1607 (operator/set! . 62))
+(1608 (operator/call . 62))
+(1609 (operator/begin . 62))
+(1610 (direct-compilator . 62))
+(1611 (direct-closed-compilator . 62))
+(1612 (nargs->domain . 62))
+(1613 (get-primop-type . 62))
+(1614 (primop-types . 62))
+(1615 (define-simple-primitive . 62))
+(1616 (simple-compilator . 62))
+(1617 (simple-closed-compilator . 62))
+(1618 (symbol-append . 62))
+(1619 (define-stob-predicate . 62))
+(1620 (define-data-struct-primitives . 62))
+(1621 (define-vector-primitives . 62))
+(1622 (define-n-ary-compiler-primitive . 62))
+(1623 (n-ary-primitive-compilator . 62))
+(1624 (call-on-arg-and-id . 62))
+(1625 (call-on-args . 62))
+(1626 (op/unspecific . 62))
+(1627 (op/literal . 62))
+(1628 (push-all-but-last . 62))
+(1629 (dispatch-protocol-size . 62))
+(1630 (make-dispatch-protocol . 62))
+(1631 (compile-forms . 62))
+(1632 (compile-forms-loop . 62))
+(1633 (compile-form . 62))
+(1634 (define-node? . 62))
+(1635 (compile-definition . 62))
+(1636 (location-contents-offset . 62))
+(1637 (make-startup-procedure . 62))
+(1638 (append-templates . 62))
+(1639 (an-ignore-values-cont . 62))
+(1640 (eval . 80))
+(1641 (load-into . 80))
+(1642 (eval-from-file . 80))
+(1643 (load . 80))
+(1644 (really-load-into . 80))
+(1645 (compile-and-run . 80))
+(1646 (display-condition . 47))
+(1647 (really-display-condition . 47))
+(1648 (*depth* . 47))
+(1649 (*length* . 47))
+(1650 (&disclose-condition . 47))
+(1651 (disclose-condition . 47))
+(1652 (limited-write . 47))
+(1653 (command-processor . 84))
+(1654 (mini-load . 84))
+(1655 (read-string . 84))
+(1656 (enum-case . 42))
+(1657 (run-threads . 40))
+(1658 (run-threads-with-housekeeper . 40))
+(1659 (round-robin-event-handler . 40))
+(1660 (make-counter . 40))
+(1661 (counter-value . 40))
+(1662 (increment-counter! . 40))
+(1663 (decrement-counter! . 40))
+(1664 (root-scheduler . 41))
+(1665 (make-root-event-handler . 41))
+(1666 (root-handler . 41))
+(1667 (cheap-display-condition . 41))
+(1668 (abort-token . 41))
+(1669 (scheme-exit-now . 41))
+(1670 (root-wait . 41))
+(1671 (one-day-of-milliseconds . 41))
+(1672 (do-some-waiting . 41))
+(1673 (deadlock-handler . 41))
+(1674 (call-when-deadlocked! . 41))
+(1675 (spawn-output-forcers . 41))
+(1676 (unspecific . 41))
+(1677 (usual-resumer . 45))
+(1678 (initialize-rts . 45))
+(1679 (start . 85))
+(1680 (make-built-in-structures . 85))
+(1681 (initialize-interaction-environment! . 85))
+(1682 (make-initial-package . 85))
+(1683 (make-tower . 85))
+(1684 (the-usual-transforms . 55))
+(1685 (define-usual-macro . 55))
+(1686 (usual-transform . 55))
+(1687 (do-spec? . 55))
+(1688 (specs? . 55))
+(1689 (case-clause? . 55))
+(1690 (process-rules . 55))
+(1691 (segment-pattern? . 55))
+(1692 (segment-template? . 55))
+(1693 (segment-depth . 55))
+(1694 (segment-tail . 55))
+(1695 (indicators-for-zero-or-more . 55))
+(1696 (find-free-names-in-syntax-rules . 55))
+(1697 (strongly-connected-components . 76))
+(1698 (find-next-vertex . 76))
+(1699 (:vertex . 76))
+(1700 (really-make-vertex . 76))
+(1701 (vertex-lowpoint . 76))
+(1702 (set-vertex-lowpoint! . 76))
+(1703 (vertex-parent . 76))
+(1704 (set-vertex-parent! . 76))
+(1705 (vertex-index . 76))
+(1706 (set-vertex-index! . 76))
+(1707 (vertex-stack . 76))
+(1708 (set-vertex-stack! . 76))
+(1709 (vertex-edges . 76))
+(1710 (set-vertex-edges! . 76))
+(1711 (vertex-data . 76))
+(1712 (vertex? . 76))
+(1713 (make-vertex . 76))
+(1714 (make-vertices . 76))
+(1715 (do-vertex . 76))
+(1716 (get-strong . 76))
+(1717 (end-vertex . 76))
+(1718 (unwind-stack . 76))
+(1719 (follow-edge . 76))
+(1720 (pop-vertex-edge! . 76))
+(1721 (find-usages . 73))
+(1722 (maybe-update-known-type . 73))
+(1723 (find-node-usages . 73))
+(1724 (analyze . 73))
+(1725 (analyze-nodes . 73))
+(1726 (usage-analyzers . 73))
+(1727 (define-usage-analyzer . 73))
+(1728 (nothing . 73))
+(1729 (add-if-free . 73))
+(1730 (:usage . 73))
+(1731 (really-make-usage . 73))
+(1732 (usage-assignment-count . 73))
+(1733 (set-assignment! . 73))
+(1734 (usage-operator-count . 73))
+(1735 (set-operator! . 73))
+(1736 (usage-reference-count . 73))
+(1737 (set-reference! . 73))
+(1738 (usage-name-node . 73))
+(1739 (usage? . 73))
+(1740 (make-usage . 73))
+(1741 (make-package-usage . 73))
+(1742 (package-usage? . 73))
+(1743 (usage-incrementator . 73))
+(1744 (note-reference! . 73))
+(1745 (note-operator! . 73))
+(1746 (note-assignment! . 73))
+(1747 (lambda-node? . 73))
+(1748 (quote-node? . 73))
+(1749 (literal-node? . 73))
+(1750 (call-node? . 73))
+(1751 (name-node? . 73))
+(1752 (define-node? . 73))
+(1753 (sort-forms . 73))
+(1754 (stuff-count . 73))
+(1755 (maybe-make-aliased . 73))
+(1756 (topologically-sort . 73))
+(1757 (:form . 73))
+(1758 (really-make-form . 73))
+(1759 (form-temp . 73))
+(1760 (set-form-temp! . 73))
+(1761 (form-free . 73))
+(1762 (set-form-free! . 73))
+(1763 (form-unaliased? . 73))
+(1764 (set-form-unaliased?! . 73))
+(1765 (form-aliases . 73))
+(1766 (set-form-aliases! . 73))
+(1767 (form-node . 73))
+(1768 (form? . 73))
+(1769 (make-form . 73))
+(1770 (insert-aliases . 73))
+(1771 (make-inline-transform . 75))
+(1772 (clean-node . 75))
+(1773 (clean-lambda . 75))
+(1774 (clean-lookup . 75))
+(1775 (unused-name . 75))
+(1776 (inline-transform . 75))
+(1777 (make-substitution . 75))
+(1778 (reconstitute . 75))
+(1779 (reconstitute-name . 75))
+(1780 (operator/name . 75))
+(1781 (operator/literal . 75))
+(1782 (qualified->name . 75))
+(1783 (get-qualified-env . 75))
+(1784 (quote-node? . 75))
+(1785 (call-node? . 75))
+(1786 (lambda-node? . 75))
+(1787 (name-node? . 75))
+(1788 (loophole-node? . 75))
+(1789 (operator . 82))
+(1790 (primop . 82))
+(1791 (simple-interface . 82))
+(1792 (package . 82))
+(1793 (transform . 82))
+(1794 (package-define-static! . 82))
+(1795 (:syntax . 71))
+(1796 (:values . 71))
+(1797 (:arguments . 71))
+(1798 (:value . 71))
+(1799 (procedure . 71))
+(1800 (:boolean . 71))
+(1801 (:char . 71))
+(1802 (:null . 71))
+(1803 (:unspecific . 71))
+(1804 (:number . 71))
+(1805 (:complex . 71))
+(1806 (:real . 71))
+(1807 (:rational . 71))
+(1808 (:integer . 71))
+(1809 (:exact-integer . 71))
+(1810 (:pair . 71))
+(1811 (:string . 71))
+(1812 (:symbol . 71))
+(1813 (:vector . 71))
+(1814 (:procedure . 71))
+(1815 (:input-port . 71))
+(1816 (:output-port . 71))
+(1817 (:error . 71))
+(1818 (:escape . 71))
+(1819 (:structure . 71))
+(1820 (:type . 71))
+(1821 (def . 70))
+(1822 (really-def . 70))
+(1823 (define-multiple . 70))
+(1824 (define-interface . 70))
+(1825 (compound-interface . 70))
+(1826 (export . 70))
+(1827 (define-structure . 70))
+(1828 (define-structures . 70))
+(1829 (structure . 70))
+(1830 (structures . 70))
+(1831 (a-package . 70))
+(1832 (receive . 70))
+(1833 (define-reflective-tower-maker . 70))
+(1834 (export-reflective-tower-maker . 70))
+(1835 (define-module . 70))
+(1836 (make-a-package . 70))
+(1837 (loser . 70))
+(1838 (interface-of . 70))
+(1839 (*verify-later!* . 70))
+(1840 (verify-later! . 70))
+(1841 (set-verify-later! . 70))
+(1842 (note-name! . 70))
+(1843 (optimizers-table . 68))
+(1844 (set-optimizer! . 68))
+(1845 (get-optimizer . 68))
+(1846 (apply-optimizers . 68))
+(1847 (collect-packages . 67))
+(1848 (package-source . 67))
+(1849 (read-files . 67))
+(1850 (package-optimizer-names . 67))
+(1851 (check-structure . 67))
+(1852 (compile-package . 69))
+(1853 (expand-package . 69))
+(1854 (define-usual-transform . 69))
+(1855 (define-primitives . 69))
+(1856 (make-define-primitive-node . 69))
+(1857 (operator/define . 69))
+(1858 (operator/primitive-procedure . 69))
+(1859 (analyze-forms . 74))
+(1860 (analyze-form . 74))
+(1861 (inlinable-rhs? . 74))
+(1862 (simple-lambda? . 74))
+(1863 (operator/name . 74))
+(1864 (simple? . 74))
+(1865 (simple-list? . 74))
+(1866 (analyzers . 74))
+(1867 (define-analyzer . 74))
+(1868 (static-value . 74))
+(1869 (really-simple-call? . 74))
+(1870 (lexical-node? . 74))
+(1871 (no-ret . 74))
+(1872 (ret . 74))
+(1873 (simple-literal? . 74))
+(1874 (require . 74))
+(1875 (*debug?* . 74))
+(1876 (package-lookup-type . 74))
+(1877 (lambda-node? . 74))
+(1878 (name-node? . 74))
+(1879 (loophole-node? . 74))
+(1880 (define-node? . 74))
+(1881 (flatten-form . 64))
+(1882 (flatten-node . 64))
+(1883 (flatteners . 64))
+(1884 (define-flattener . 64))
+(1885 (flatten-list . 64))
+(1886 (no-free-vars . 64))
+(1887 (flatten-lambda . 64))
+(1888 (convert-lambda-body . 64))
+(1889 (add-cells . 64))
+(1890 (assigned? . 64))
+(1891 (mark-set-variables! . 64))
+(1892 (mark-sets . 64))
+(1893 (define-set-marker . 64))
+(1894 (no-sets . 64))
+(1895 (make-cell . 64))
+(1896 (make-unassigned-cell . 64))
+(1897 (make-cell-ref . 64))
+(1898 (make-cell-set! . 64))
+(1899 (make-primop-call . 64))
+(1900 (operator/flat-lambda . 64))
+(1901 (operator/lambda . 64))
+(1902 (operator/begin . 64))
+(1903 (operator/literal . 64))
+(1904 (operator/call . 64))
+(1905 (operator/unassigned . 64))
+(1906 (operator/set! . 64))
+(1907 (define-node? . 64))
+(1908 (lambda-node? . 64))
+(1909 (define-primop . 64))
+(1910 (temp0 . 64))
+(1911 (make-cell-primop . 64))
+(1912 (temp1 . 64))
+(1913 (cell-ref-primop . 64))
+(1914 (temp2 . 64))
+(1915 (cell-set!-primop . 64))
+(1916 (union . 64))
+(1917 (set-difference . 64))
+(1918 (ensure-loaded . 81))
+-
+; Template uid -> name, parent, pc in parent, env maps
+(0 scheme-level-0 #f #f ())
+(1 atan 0 7 ())
+(2 scheme-level-0 #f #f ())
+(3 set-location-defined?! 2 7 ())
+(4 scheme-level-0 #f #f ())
+(5 acos 4 7 ())
+(6 scheme-level-0 #f #f ())
+(7 vm-extension 6 7 ())
+(8 scheme-level-0 #f #f ())
+(9 asin 8 7 ())
+(10 scheme-level-0 #f #f ())
+(11 location-defined? 10 7 ())
+(12 scheme-level-0 #f #f ())
+(13 time 12 7 ())
+(14 scheme-level-0 #f #f ())
+(15 template-set! 14 7 ())
+(16 scheme-level-0 #f #f ())
+(17 scheme-level-0 #f #f ())
+(18 cons 17 7 ())
+(19 scheme-level-0 #f #f ())
+(20 wait 19 7 ())
+(21 scheme-level-0 #f #f ())
+(22 trap 21 7 ())
+(23 scheme-level-0 #f #f ())
+(24 assq 23 7 ())
+(25 scheme-level-0 #f #f ())
+(26 make-weak-pointer 25 7 ())
+(27 scheme-level-0 #f #f ())
+(28 lookup-shared-binding 27 7 ())
+(29 scheme-level-0 #f #f ())
+(30 push 29 7 ())
+(31 scheme-level-0 #f #f ())
+(32 set-contents! 31 7 ())
+(33 scheme-level-0 #f #f ())
+(34 read-char 33 7 ())
+(35 scheme-level-0 #f #f ())
+(36 make-cell 35 7 ())
+(37 scheme-level-0 #f #f ())
+(38 sqrt 37 7 ())
+(39 scheme-level-0 #f #f ())
+(40 * 39 7 ())
+(41 scheme-level-0 #f #f ())
+(42 contents 41 7 ())
+(43 scheme-level-0 #f #f ())
+(44 + 43 7 ())
+(45 scheme-level-0 #f #f ())
+(46 peek-char 45 7 ())
+(47 scheme-level-0 #f #f ())
+(48 - 47 7 ())
+(49 scheme-level-0 #f #f ())
+(50 continuation-set! 49 7 ())
+(51 scheme-level-0 #f #f ())
+(52 / 51 7 ())
+(53 scheme-level-0 #f #f ())
+(54 weak-pointer? 53 7 ())
+(55 scheme-level-0 #f #f ())
+(56 quotient 55 7 ())
+(57 scheme-level-0 #f #f ())
+(58 close-channel 57 7 ())
+(59 scheme-level-0 #f #f ())
+(60 channel-abort 59 7 ())
+(61 scheme-level-0 #f #f ())
+(62 char? 61 7 ())
+(63 scheme-level-0 #f #f ())
+(64 < 63 7 ())
+(65 scheme-level-0 #f #f ())
+(66 = 65 7 ())
+(67 scheme-level-0 #f #f ())
+(68 > 67 7 ())
+(69 scheme-level-0 #f #f ())
+(70 make-location 69 7 ())
+(71 scheme-level-0 #f #f ())
+(72 imag-part 71 7 ())
+(73 scheme-level-0 #f #f ())
+(74 set-port-data! 73 7 ())
+(75 scheme-level-0 #f #f ())
+(76 make-template 75 7 ())
+(77 scheme-level-0 #f #f ())
+(78 real? 77 7 ())
+(79 scheme-level-0 #f #f ())
+(80 real-part 79 7 ())
+(81 scheme-level-0 #f #f ())
+(82 get-cont-from-heap 81 7 ())
+(83 scheme-level-0 #f #f ())
+(84 record-length 83 7 ())
+(85 scheme-level-0 #f #f ())
+(86 port-data 85 7 ())
+(87 scheme-level-0 #f #f ())
+(88 pair? 87 7 ())
+(89 scheme-level-0 #f #f ())
+(90 make-port 89 7 ())
+(91 scheme-level-0 #f #f ())
+(92 set-port-lock! 91 7 ())
+(93 scheme-level-0 #f #f ())
+(94 return-from-exception 93 7 ())
+(95 scheme-level-0 #f #f ())
+(96 location? 95 7 ())
+(97 scheme-level-0 #f #f ())
+(98 channel-maybe-read 97 7 ())
+(99 scheme-level-0 #f #f ())
+(100 checked-record-ref 99 7 ())
+(101 scheme-level-0 #f #f ())
+(102 add-finalizer! 101 7 ())
+(103 scheme-level-0 #f #f ())
+(104 rational? 103 7 ())
+(105 scheme-level-0 #f #f ())
+(106 template? 105 7 ())
+(107 scheme-level-0 #f #f ())
+(108 port-lock 107 7 ())
+(109 scheme-level-0 #f #f ())
+(110 vector-length 109 7 ())
+(111 scheme-level-0 #f #f ())
+(112 make-continuation 111 7 ())
+(113 scheme-level-0 #f #f ())
+(114 string-length 113 7 ())
+(115 scheme-level-0 #f #f ())
+(116 shared-binding-ref 115 7 ())
+(117 scheme-level-0 #f #f ())
+(118 port? 117 7 ())
+(119 scheme-level-0 #f #f ())
+(120 angle 119 7 ())
+(121 scheme-level-0 #f #f ())
+(122 false 121 7 ())
+(123 scheme-level-0 #f #f ())
+(124 remainder 123 7 ())
+(125 scheme-level-0 #f #f ())
+(126 continuation? 125 7 ())
+(127 scheme-level-0 #f #f ())
+(128 binary-reduce1 127 7 ())
+(129 scheme-level-0 #f #f ())
+(130 binary-reduce2 129 7 ())
+(131 scheme-level-0 #f #f ())
+(132 char<? 131 7 ())
+(133 scheme-level-0 #f #f ())
+(134 char=? 133 7 ())
+(135 scheme-level-0 #f #f ())
+(136 <= 135 7 ())
+(137 scheme-level-0 #f #f ())
+(138 magnitude 137 7 ())
+(139 scheme-level-0 #f #f ())
+(140 >= 139 7 ())
+(141 scheme-level-0 #f #f ())
+(142 with-continuation 141 7 ())
+(143 scheme-level-0 #f #f ())
+(144 floor 143 7 ())
+(145 scheme-level-0 #f #f ())
+(146 apply 145 7 ())
+(147 scheme-level-0 #f #f ())
+(148 memory-status 147 7 ())
+(149 scheme-level-0 #f #f ())
+(150 checked-record-set! 149 7 ())
+(151 scheme-level-0 #f #f ())
+(152 inexact->exact 151 7 ())
+(153 scheme-level-0 #f #f ())
+(154 exact->inexact 153 7 ())
+(155 scheme-level-0 #f #f ())
+(156 error 155 7 ())
+(157 scheme-level-0 #f #f ())
+(158 extended-number-length 157 7 ())
+(159 scheme-level-0 #f #f ())
+(160 open-channels-list 159 7 ())
+(161 scheme-level-0 #f #f ())
+(162 channel-id 161 7 ())
+(163 scheme-level-0 #f #f ())
+(164 shared-binding-set! 163 7 ())
+(165 scheme-level-0 #f #f ())
+(166 numerator 165 7 ())
+(167 scheme-level-0 #f #f ())
+(168 eof-object 167 7 ())
+(169 scheme-level-0 #f #f ())
+(170 byte-vector-length 169 7 ())
+(171 scheme-level-0 #f #f ())
+(172 record-ref 171 7 ())
+(173 scheme-level-0 #f #f ())
+(174 make-polar 173 7 ())
+(175 scheme-level-0 #f #f ())
+(176 write-char 175 7 ())
+(177 scheme-level-0 #f #f ())
+(178 symbol->string 177 7 ())
+(179 scheme-level-0 #f #f ())
+(180 exact? 179 7 ())
+(181 scheme-level-0 #f #f ())
+(182 vector-ref 181 7 ())
+(183 scheme-level-0 #f #f ())
+(184 set-current-thread! 183 7 ())
+(185 scheme-level-0 #f #f ())
+(186 immutable? 185 7 ())
+(187 scheme-level-0 #f #f ())
+(188 set-exception-handlers! 187 7 ())
+(189 scheme-level-0 #f #f ())
+(190 string-ref 189 7 ())
+(191 scheme-level-0 #f #f ())
+(192 set-port-index! 191 7 ())
+(193 scheme-level-0 #f #f ())
+(194 make-shared-binding 193 7 ())
+(195 scheme-level-0 #f #f ())
+(196 current-thread 195 7 ())
+(197 scheme-level-0 #f #f ())
+(198 channel-status 197 7 ())
+(199 scheme-level-0 #f #f ())
+(200 set-port-limit! 199 7 ())
+(201 scheme-level-0 #f #f ())
+(202 shared-binding-name 201 7 ())
+(203 scheme-level-0 #f #f ())
+(204 port-index 203 7 ())
+(205 scheme-level-0 #f #f ())
+(206 make-immutable! 205 7 ())
+(207 scheme-level-0 #f #f ())
+(208 set-enabled-interrupts! 207 7 ())
+(209 scheme-level-0 #f #f ())
+(210 port-limit 209 7 ())
+(211 scheme-level-0 #f #f ())
+(212 ascii->char 211 7 ())
+(213 scheme-level-0 #f #f ())
+(214 char->ascii 213 7 ())
+(215 scheme-level-0 #f #f ())
+(216 undefine-shared-binding 215 7 ())
+(217 scheme-level-0 #f #f ())
+(218 record-set! 217 7 ())
+(219 scheme-level-0 #f #f ())
+(220 shared-binding? 219 7 ())
+(221 scheme-level-0 #f #f ())
+(222 eof-object? 221 7 ())
+(223 scheme-level-0 #f #f ())
+(224 set-interrupt-handlers! 223 7 ())
+(225 scheme-level-0 #f #f ())
+(226 record 225 7 ())
+(227 scheme-level-0 #f #f ())
+(228 schedule-interrupt 227 7 ())
+(229 scheme-level-0 #f #f ())
+(230 channel-maybe-write 229 7 ())
+(231 scheme-level-0 #f #f ())
+(232 unspecific 231 7 ())
+(233 scheme-level-0 #f #f ())
+(234 extended-number-ref 233 7 ())
+(235 scheme-level-0 #f #f ())
+(236 vector-set! 235 7 ())
+(237 scheme-level-0 #f #f ())
+(238 copy-bytes! 237 7 ())
+(239 scheme-level-0 #f #f ())
+(240 string-set! 239 7 ())
+(241 scheme-level-0 #f #f ())
+(242 unassigned 241 7 ())
+(243 scheme-level-0 #f #f ())
+(244 call-external-value 243 7 ())
+(245 scheme-level-0 #f #f ())
+(246 values 245 7 ())
+(247 scheme-level-0 #f #f ())
+(248 intern 247 7 ())
+(249 scheme-level-0 #f #f ())
+(250 vector 249 7 ())
+(251 scheme-level-0 #f #f ())
+(252 byte-vector-ref 251 7 ())
+(253 scheme-level-0 #f #f ())
+(254 make-double 253 7 ())
+(255 scheme-level-0 #f #f ())
+(256 make-record 255 7 ())
+(257 scheme-level-0 #f #f ())
+(258 set-location-id! 257 7 ())
+(259 scheme-level-0 #f #f ())
+(260 location-id 259 7 ())
+(261 scheme-level-0 #f #f ())
+(262 bitwise-and 261 7 ())
+(263 scheme-level-0 #f #f ())
+(264 eq? 263 7 ())
+(265 scheme-level-0 #f #f ())
+(266 write-image 265 7 ())
+(267 scheme-level-0 #f #f ())
+(268 double? 267 7 ())
+(269 scheme-level-0 #f #f ())
+(270 extended-number-set! 269 7 ())
+(271 scheme-level-0 #f #f ())
+(272 make-vector 271 7 ())
+(273 scheme-level-0 #f #f ())
+(274 record? 273 7 ())
+(275 scheme-level-0 #f #f ())
+(276 make-string 275 7 ())
+(277 scheme-level-0 #f #f ())
+(278 set-port-buffer! 277 7 ())
+(279 scheme-level-0 #f #f ())
+(280 primitive-catch 279 7 ())
+(281 scheme-level-0 #f #f ())
+(282 string-hash 281 7 ())
+(283 scheme-level-0 #f #f ())
+(284 template-length 283 7 ())
+(285 scheme-level-0 #f #f ())
+(286 number? 285 7 ())
+(287 scheme-level-0 #f #f ())
+(288 port-buffer 287 7 ())
+(289 scheme-level-0 #f #f ())
+(290 byte-vector-set! 289 7 ())
+(291 scheme-level-0 #f #f ())
+(292 bitwise-ior 291 7 ())
+(293 scheme-level-0 #f #f ())
+(294 set-car! 293 7 ())
+(295 scheme-level-0 #f #f ())
+(296 closure-env 295 7 ())
+(297 scheme-level-0 #f #f ())
+(298 vector? 297 7 ())
+(299 scheme-level-0 #f #f ())
+(300 bitwise-not 299 7 ())
+(301 scheme-level-0 #f #f ())
+(302 set-cdr! 301 7 ())
+(303 scheme-level-0 #f #f ())
+(304 symbol? 303 7 ())
+(305 scheme-level-0 #f #f ())
+(306 string? 305 7 ())
+(307 scheme-level-0 #f #f ())
+(308 car 307 7 ())
+(309 scheme-level-0 #f #f ())
+(310 bitwise-xor 309 7 ())
+(311 scheme-level-0 #f #f ())
+(312 cdr 311 7 ())
+(313 scheme-level-0 #f #f ())
+(314 find-all-records 313 7 ())
+(315 scheme-level-0 #f #f ())
+(316 continuation-length 315 7 ())
+(317 scheme-level-0 #f #f ())
+(318 log 317 7 ())
+(319 scheme-level-0 #f #f ())
+(320 message 319 7 ())
+(321 scheme-level-0 #f #f ())
+(322 tan 321 7 ())
+(323 scheme-level-0 #f #f ())
+(324 collect 323 7 ())
+(325 scheme-level-0 #f #f ())
+(326 cos 325 7 ())
+(327 scheme-level-0 #f #f ())
+(328 channel-os-index 327 7 ())
+(329 scheme-level-0 #f #f ())
+(330 make-extended-number 329 7 ())
+(331 scheme-level-0 #f #f ())
+(332 set-port-status! 331 7 ())
+(333 scheme-level-0 #f #f ())
+(334 sin 333 7 ())
+(335 scheme-level-0 #f #f ())
+(336 exp 335 7 ())
+(337 scheme-level-0 #f #f ())
+(338 pop 337 7 ())
+(339 scheme-level-0 #f #f ())
+(340 port-status 339 7 ())
+(341 scheme-level-0 #f #f ())
+(342 return-from-callback 341 7 ())
+(343 scheme-level-0 #f #f ())
+(344 set-port-locked?! 343 7 ())
+(345 scheme-level-0 #f #f ())
+(346 make-byte-vector 345 7 ())
+(347 scheme-level-0 #f #f ())
+(348 weak-pointer-ref 347 7 ())
+(349 scheme-level-0 #f #f ())
+(350 call-with-values 349 7 ())
+(351 scheme-level-0 #f #f ())
+(352 denominator 351 7 ())
+(353 scheme-level-0 #f #f ())
+(354 reverse-list->string 353 7 ())
+(355 scheme-level-0 #f #f ())
+(356 port-locked? 355 7 ())
+(357 scheme-level-0 #f #f ())
+(358 extended-number? 357 7 ())
+(359 scheme-level-0 #f #f ())
+(360 shared-binding-is-import? 359 7 ())
+(361 scheme-level-0 #f #f ())
+(362 find-all 361 7 ())
+(363 scheme-level-0 #f #f ())
+(364 cell-ref 363 7 ())
+(365 scheme-level-0 #f #f ())
+(366 byte-vector? 365 7 ())
+(367 scheme-level-0 #f #f ())
+(368 string=? 367 7 ())
+(369 scheme-level-0 #f #f ())
+(370 open-channel 369 7 ())
+(371 scheme-level-0 #f #f ())
+(372 channel? 371 7 ())
+(373 scheme-level-0 #f #f ())
+(374 make-rectangular 373 7 ())
+(375 scheme-level-0 #f #f ())
+(376 set-session-data! 375 7 ())
+(377 scheme-level-0 #f #f ())
+(378 template-ref 377 7 ())
+(379 scheme-level-0 #f #f ())
+(380 make-closure 379 7 ())
+(381 scheme-level-0 #f #f ())
+(382 session-data 381 7 ())
+(383 scheme-level-0 #f #f ())
+(384 integer? 383 7 ())
+(385 scheme-level-0 #f #f ())
+(386 signal-condition 385 7 ())
+(387 scheme-level-0 #f #f ())
+(388 port-handler 387 7 ())
+(389 scheme-level-0 #f #f ())
+(390 set-port-pending-eof?! 389 7 ())
+(391 scheme-level-0 #f #f ())
+(392 define-shared-binding 391 7 ())
+(393 scheme-level-0 #f #f ())
+(394 arithmetic-shift 393 7 ())
+(395 scheme-level-0 #f #f ())
+(396 complex? 395 7 ())
+(397 scheme-level-0 #f #f ())
+(398 port-pending-eof? 397 7 ())
+(399 scheme-level-0 #f #f ())
+(400 cell-set! 399 7 ())
+(401 scheme-level-0 #f #f ())
+(402 binary-comparison-reduce2 401 7 ())
+(403 scheme-level-0 #f #f ())
+(404 scheme-level-0 #f #f ())
+(405 closure? 404 7 ())
+(406 scheme-level-0 #f #f ())
+(407 continuation-ref 406 7 ())
+(408 scheme-level-0 #f #f ())
+(409 closure-template 408 7 ())
+(410 scheme-level-0 #f #f ())
+(411 current-cont 410 7 ())
+(412 scheme-level-0 #f #f ())
+(413 char->integer 412 7 ())
+(414 scheme-level-0 #f #f ())
+(415 integer->char 414 7 ())
+(416 scheme-level-0 #f #f ())
+(417 invoke-closure 416 7 ())
+(418 scheme-level-0 #f #f ())
+(419 primitive-cwcc 418 7 ())
+(420 #f 419 8 ())
+(421 scheme-level-0 #f #f ())
+(422 make-undefined-location 421 7 ())
+(423 scheme-level-0 #f #f ())
+(424 location-assigned? 423 7 ())
+(425 scheme-level-0 #f #f ())
+(426 vector-unassigned? 425 7 ())
+(427 scheme-level-0 #f #f ())
+(428 string-copy 427 7 ())
+(429 scheme-level-0 #f #f ())
+(430 string->symbol 429 7 ())
+(431 scheme-level-0 #f #f ())
+(432 input-port? 431 7 ())
+(433 scheme-level-0 #f #f ())
+(434 output-port? 433 7 ())
+(435 scheme-level-0 #f #f ())
+(436 make-code-vector 435 7 ())
+(437 scheme-level-0 #f #f ())
+(438 code-vector? 437 7 ())
+(439 scheme-level-0 #f #f ())
+(440 code-vector-length 439 7 ())
+(441 scheme-level-0 #f #f ())
+(442 code-vector-ref 441 7 ())
+(443 scheme-level-0 #f #f ())
+(444 code-vector-set! 443 7 ())
+(445 scheme-level-0 #f #f ())
+(446 buffer-length 445 7 ())
+(447 scheme-level-0 #f #f ())
+(448 channel-read 447 7 ())
+(449 #f 448 6 ())
+(450 loop 449 19 ())
+(451 scheme-level-0 #f #f ())
+(452 channel-write 451 7 ())
+(453 loop 452 19 ())
+(454 scheme-level-0 #f #f ())
+(455 lookup-imported-binding 454 7 ())
+(456 scheme-level-0 #f #f ())
+(457 lookup-exported-binding 456 7 ())
+(458 scheme-level-0 #f #f ())
+(459 define-imported-binding 458 7 ())
+(460 scheme-level-0 #f #f ())
+(461 define-exported-binding 460 7 ())
+(462 scheme-level-0 #f #f ())
+(463 undefine-imported-binding 462 7 ())
+(464 scheme-level-0 #f #f ())
+(465 undefine-exported-binding 464 7 ())
+(466 scheme-level-0 #f #f ())
+(467 debug-message 466 7 ())
+(468 scheme-level-0 #f #f ())
+(469 signal 468 7 ())
+(470 scheme-level-0 #f #f ())
+(471 warn 470 7 ())
+(472 scheme-level-0 #f #f ())
+(473 syntax-error 472 7 ())
+(474 scheme-level-0 #f #f ())
+(475 call-error 474 7 ())
+(476 scheme-level-0 #f #f ())
+(477 scheme-level-0 #f #f ())
+(478 scheme-level-1 #f #f ())
+(479 scheme-level-1 #f #f ())
+(480 scheme-level-1 #f #f ())
+(481 scheme-level-1 #f #f ())
+(482 scheme-level-1 #f #f ())
+(483 scheme-level-1 #f #f ())
+(484 scheme-level-1 #f #f ())
+(485 scheme-level-1 #f #f ())
+(486 scheme-level-1 #f #f ())
+(487 scheme-level-1 #f #f ())
+(488 scheme-level-1 #f #f ())
+(489 scheme-level-1 #f #f ())
+(490 #f 489 11 ())
+(491 scheme-level-1 #f #f ())
+(492 #f 491 11 ())
+(493 scheme-level-1 #f #f ())
+(494 scheme-level-1 #f #f ())
+(495 scheme-level-1 #f #f ())
+(496 scheme-level-1 #f #f ())
+(497 scheme-level-1 #f #f ())
+(498 scheme-level-1 #f #f ())
+(499 scheme-level-1 #f #f ())
+(500 not 499 7 ())
+(501 scheme-level-1 #f #f ())
+(502 boolean? 501 7 ())
+(503 scheme-level-1 #f #f ())
+(504 eqv? 503 7 ())
+(505 scheme-level-1 #f #f ())
+(506 equal? 505 7 ())
+(507 loop 506 156 ())
+(508 scheme-level-1 #f #f ())
+(509 null? 508 7 ())
+(510 scheme-level-1 #f #f ())
+(511 inexact? 510 7 ())
+(512 scheme-level-1 #f #f ())
+(513 max-or-min 512 7 ())
+(514 loop 513 34 ())
+(515 scheme-level-1 #f #f ())
+(516 max 515 7 ())
+(517 scheme-level-1 #f #f ())
+(518 min 517 7 ())
+(519 scheme-level-1 #f #f ())
+(520 abs 519 7 ())
+(521 scheme-level-1 #f #f ())
+(522 zero? 521 7 ())
+(523 scheme-level-1 #f #f ())
+(524 positive? 523 7 ())
+(525 scheme-level-1 #f #f ())
+(526 negative? 525 7 ())
+(527 scheme-level-1 #f #f ())
+(528 even? 527 7 ())
+(529 scheme-level-1 #f #f ())
+(530 odd? 529 7 ())
+(531 scheme-level-1 #f #f ())
+(532 caar 531 7 ())
+(533 scheme-level-1 #f #f ())
+(534 cadr 533 7 ())
+(535 scheme-level-1 #f #f ())
+(536 cdar 535 7 ())
+(537 scheme-level-1 #f #f ())
+(538 cddr 537 7 ())
+(539 scheme-level-1 #f #f ())
+(540 caaar 539 7 ())
+(541 scheme-level-1 #f #f ())
+(542 caadr 541 7 ())
+(543 scheme-level-1 #f #f ())
+(544 cadar 543 7 ())
+(545 scheme-level-1 #f #f ())
+(546 caddr 545 7 ())
+(547 scheme-level-1 #f #f ())
+(548 cdaar 547 7 ())
+(549 scheme-level-1 #f #f ())
+(550 cdadr 549 7 ())
+(551 scheme-level-1 #f #f ())
+(552 cddar 551 7 ())
+(553 scheme-level-1 #f #f ())
+(554 cdddr 553 7 ())
+(555 scheme-level-1 #f #f ())
+(556 caaaar 555 7 ())
+(557 scheme-level-1 #f #f ())
+(558 caaadr 557 7 ())
+(559 scheme-level-1 #f #f ())
+(560 caadar 559 7 ())
+(561 scheme-level-1 #f #f ())
+(562 caaddr 561 7 ())
+(563 scheme-level-1 #f #f ())
+(564 cadaar 563 7 ())
+(565 scheme-level-1 #f #f ())
+(566 cadadr 565 7 ())
+(567 scheme-level-1 #f #f ())
+(568 caddar 567 7 ())
+(569 scheme-level-1 #f #f ())
+(570 cadddr 569 7 ())
+(571 scheme-level-1 #f #f ())
+(572 cdaaar 571 7 ())
+(573 scheme-level-1 #f #f ())
+(574 cdaadr 573 7 ())
+(575 scheme-level-1 #f #f ())
+(576 cdadar 575 7 ())
+(577 scheme-level-1 #f #f ())
+(578 cdaddr 577 7 ())
+(579 scheme-level-1 #f #f ())
+(580 cddaar 579 7 ())
+(581 scheme-level-1 #f #f ())
+(582 cddadr 581 7 ())
+(583 scheme-level-1 #f #f ())
+(584 cdddar 583 7 ())
+(585 scheme-level-1 #f #f ())
+(586 cddddr 585 7 ())
+(587 scheme-level-1 #f #f ())
+(588 list 587 7 ())
+(589 scheme-level-1 #f #f ())
+(590 real-length 589 7 ())
+(591 scheme-level-1 #f #f ())
+(592 length 591 7 ())
+(593 scheme-level-1 #f #f ())
+(594 reduce 593 7 ())
+(595 scheme-level-1 #f #f ())
+(596 append 595 7 ())
+(597 recur 596 34 ())
+(598 scheme-level-1 #f #f ())
+(599 append-reverse 598 7 ())
+(600 scheme-level-1 #f #f ())
+(601 reverse 600 7 ())
+(602 scheme-level-1 #f #f ())
+(603 list-tail 602 7 ())
+(604 scheme-level-1 #f #f ())
+(605 list-ref 604 7 ())
+(606 scheme-level-1 #f #f ())
+(607 mem 606 7 ())
+(608 #f 607 6 ())
+(609 loop 608 18 ())
+(610 scheme-level-1 #f #f ())
+(611 ass 610 7 ())
+(612 #f 611 6 ())
+(613 loop 612 18 ())
+(614 scheme-level-1 #f #f ())
+(615 list? 614 7 ())
+(616 recur 615 21 ())
+(617 scheme-level-1 #f #f ())
+(618 char>? 617 7 ())
+(619 scheme-level-1 #f #f ())
+(620 char>=? 619 7 ())
+(621 scheme-level-1 #f #f ())
+(622 char<=? 621 7 ())
+(623 scheme-level-1 #f #f ())
+(624 char-whitespace? 623 7 ())
+(625 scheme-level-1 #f #f ())
+(626 char-lower-case? 625 7 ())
+(627 scheme-level-1 #f #f ())
+(628 char-upper-case? 627 7 ())
+(629 scheme-level-1 #f #f ())
+(630 char-numeric? 629 7 ())
+(631 scheme-level-1 #f #f ())
+(632 char-alphabetic? 631 7 ())
+(633 scheme-level-1 #f #f ())
+(634 make-character-map 633 7 ())
+(635 loop##6 634 27 ())
+(636 scheme-level-1 #f #f ())
+(637 char-upcase 636 7 ())
+(638 scheme-level-1 #f #f ())
+(639 char-downcase 638 7 ())
+(640 scheme-level-1 #f #f ())
+(641 char-ci-compare 640 7 ())
+(642 #f 641 6 ())
+(643 scheme-level-1 #f #f ())
+(644 list->string 643 7 ())
+(645 loop##8 644 36 ())
+(646 scheme-level-1 #f #f ())
+(647 string 646 7 ())
+(648 scheme-level-1 #f #f ())
+(649 substring 648 7 ())
+(650 loop##9 649 26 ())
+(651 scheme-level-1 #f #f ())
+(652 string-append 651 7 ())
+(653 #f 652 12 ())
+(654 loop 652 60 ())
+(655 loop##10 654 40 ())
+(656 scheme-level-1 #f #f ())
+(657 string->list 656 7 ())
+(658 loop##11 657 18 ())
+(659 scheme-level-1 #f #f ())
+(660 unspecific 659 7 ())
+(661 scheme-level-1 #f #f ())
+(662 string-fill! 661 7 ())
+(663 loop##12 662 18 ())
+(664 scheme-level-1 #f #f ())
+(665 make-string=? 664 7 ())
+(666 #f 665 6 ())
+(667 loop 666 36 ())
+(668 scheme-level-1 #f #f ())
+(669 make-string<? 668 7 ())
+(670 #f 669 6 ())
+(671 loop 670 49 ())
+(672 scheme-level-1 #f #f ())
+(673 string>? 672 7 ())
+(674 scheme-level-1 #f #f ())
+(675 string<=? 674 7 ())
+(676 scheme-level-1 #f #f ())
+(677 string>=? 676 7 ())
+(678 scheme-level-1 #f #f ())
+(679 string-ci>? 678 7 ())
+(680 scheme-level-1 #f #f ())
+(681 string-ci<=? 680 7 ())
+(682 scheme-level-1 #f #f ())
+(683 string-ci>=? 682 7 ())
+(684 scheme-level-1 #f #f ())
+(685 vector->list 684 7 ())
+(686 loop##14 685 11 ())
+(687 scheme-level-1 #f #f ())
+(688 list->vector 687 7 ())
+(689 loop##15 688 35 ())
+(690 scheme-level-1 #f #f ())
+(691 vector-fill! 690 7 ())
+(692 loop##16 691 19 ())
+(693 scheme-level-1 #f #f ())
+(694 map1 693 7 ())
+(695 scheme-level-1 #f #f ())
+(696 any 695 7 ())
+(697 scheme-level-1 #f #f ())
+(698 map2+ 697 7 ())
+(699 scheme-level-1 #f #f ())
+(700 map 699 7 ())
+(701 scheme-level-1 #f #f ())
+(702 for-each1 701 7 ())
+(703 loop 702 18 ())
+(704 scheme-level-1 #f #f ())
+(705 for-each2+ 704 7 ())
+(706 loop 705 21 ())
+(707 scheme-level-1 #f #f ())
+(708 for-each 707 7 ())
+(709 scheme-level-1 #f #f ())
+(710 make-promise 709 7 ())
+(711 #f 710 11 ())
+(712 scheme-level-1 #f #f ())
+(713 force 712 7 ())
+(714 scheme-level-1 #f #f ())
+(715 filter 714 7 ())
+(716 #f 715 6 ())
+(717 scheme-level-1 #f #f ())
+(718 pos 717 7 ())
+(719 #f 718 6 ())
+(720 loop 719 22 ())
+(721 scheme-level-1 #f #f ())
+(722 every 721 7 ())
+(723 scheme-level-1 #f #f ())
+(724 sublist 723 7 ())
+(725 recur 724 58 ())
+(726 scheme-level-1 #f #f ())
+(727 last 726 7 ())
+(728 scheme-level-1 #f #f ())
+(729 insert 728 7 ())
+(730 scheme-level-1 #f #f ())
+(731 fold 730 7 ())
+(732 loop##20 731 11 ())
+(733 scheme-level-1 #f #f ())
+(734 fold->2 733 7 ())
+(735 loop 734 24 ())
+(736 #f 735 25 ())
+(737 scheme-level-1 #f #f ())
+(738 fold->3 737 7 ())
+(739 loop 738 27 ())
+(740 #f 739 28 ())
+(741 scheme-level-1 #f #f ())
+(742 modulo 741 7 ())
+(743 scheme-level-1 #f #f ())
+(744 ceiling 743 7 ())
+(745 scheme-level-1 #f #f ())
+(746 truncate 745 7 ())
+(747 scheme-level-1 #f #f ())
+(748 round 747 7 ())
+(749 scheme-level-1 #f #f ())
+(750 euclid 749 7 ())
+(751 scheme-level-1 #f #f ())
+(752 gcd 751 7 ())
+(753 #f 752 8 ())
+(754 scheme-level-1 #f #f ())
+(755 lcm 754 7 ())
+(756 #f 755 8 ())
+(757 scheme-level-1 #f #f ())
+(758 raise-to-integer-power 757 7 ())
+(759 loop 758 39 ())
+(760 scheme-level-1 #f #f ())
+(761 expt 760 7 ())
+(762 scheme-level-1 #f #f ())
+(763 simplest-rational 762 7 ())
+(764 simplest-rational-internal 763 11 ())
+(765 scheme-level-1 #f #f ())
+(766 rationalize 765 7 ())
+(767 records #f #f ())
+(768 #f 767 7 ())
+(769 records #f #f ())
+(770 records #f #f ())
+(771 records #f #f ())
+(772 records #f #f ())
+(773 record-type 772 7 ())
+(774 records #f #f ())
+(775 record-type-name 774 7 ())
+(776 records #f #f ())
+(777 make-default-record-discloser 776 7 ())
+(778 #f 777 6 ())
+(779 records #f #f ())
+(780 make-record-type 779 7 ())
+(781 records #f #f ())
+(782 record-type? 781 7 ())
+(783 records #f #f ())
+(784 record-type-resumer 783 7 ())
+(785 records #f #f ())
+(786 set-record-type-resumer! 785 7 ())
+(787 records #f #f ())
+(788 record-type-uid 787 7 ())
+(789 records #f #f ())
+(790 record-type-field-names 789 7 ())
+(791 records #f #f ())
+(792 record-type-number-of-fields 791 7 ())
+(793 records #f #f ())
+(794 record-type-discloser 793 7 ())
+(795 records #f #f ())
+(796 set-record-type-discloser! 795 7 ())
+(797 records #f #f ())
+(798 record-field-index 797 7 ())
+(799 loop 798 28 ())
+(800 records #f #f ())
+(801 record-constructor 800 7 ())
+(802 #f 801 10 ())
+(803 #f 801 41 ())
+(804 loop 803 45 ())
+(805 records #f #f ())
+(806 record-accessor 805 7 ())
+(807 #f 806 62 ())
+(808 records #f #f ())
+(809 record-modifier 808 7 ())
+(810 #f 809 62 ())
+(811 records #f #f ())
+(812 record-predicate 811 7 ())
+(813 #f 812 6 ())
+(814 records #f #f ())
+(815 define-record-discloser 814 7 ())
+(816 records #f #f ())
+(817 disclose-record 816 7 ())
+(818 records #f #f ())
+(819 define-record-resumer 818 7 ())
+(820 records #f #f ())
+(821 resume-record 820 7 ())
+(822 records #f #f ())
+(823 initialize-records! 822 7 ())
+(824 loop##23 823 18 ())
+(825 records #f #f ())
+(826 records #f #f ())
+(827 records #f #f ())
+(828 records #f #f ())
+(829 define-record-types #f #f ())
+(830 methods #f #f ())
+(831 &add-method! 830 59 ())
+(832 methods #f #f ())
+(833 &disclose 832 52 ())
+(834 methods #f #f ())
+(835 &disclose 834 52 ())
+(836 methods #f #f ())
+(837 methods #f #f ())
+(838 disclose 837 56 ())
+(839 methods #f #f ())
+(840 &same-type? 839 56 ())
+(841 methods #f #f ())
+(842 &type-priority 841 52 ())
+(843 methods #f #f ())
+(844 &type-predicate 843 52 ())
+(845 methods #f #f ())
+(846 #f 845 11 ())
+(847 methods #f #f ())
+(848 singleton-value 847 7 ())
+(849 methods #f #f ())
+(850 singleton 849 7 ())
+(851 methods #f #f ())
+(852 methods #f #f ())
+(853 &same-type? 852 56 ())
+(854 methods #f #f ())
+(855 &same-type? 854 56 ())
+(856 methods #f #f ())
+(857 methods #f #f ())
+(858 same-type? 857 60 ())
+(859 methods #f #f ())
+(860 &type-superiors 859 52 ())
+(861 methods #f #f ())
+(862 &type-superiors 861 52 ())
+(863 methods #f #f ())
+(864 methods #f #f ())
+(865 type-superiors 864 56 ())
+(866 methods #f #f ())
+(867 &type-priority 866 52 ())
+(868 methods #f #f ())
+(869 &type-priority 868 52 ())
+(870 methods #f #f ())
+(871 methods #f #f ())
+(872 type-priority 871 56 ())
+(873 methods #f #f ())
+(874 &type-predicate 873 52 ())
+(875 methods #f #f ())
+(876 &type-predicate 875 52 ())
+(877 methods #f #f ())
+(878 methods #f #f ())
+(879 type-predicate 878 56 ())
+(880 methods #f #f ())
+(881 add-method! 880 52 ())
+(882 methods #f #f ())
+(883 methods #f #f ())
+(884 add-method! 883 60 ())
+(885 methods #f #f ())
+(886 #f 885 11 ())
+(887 methods #f #f ())
+(888 set-method-table-methods! 887 7 ())
+(889 methods #f #f ())
+(890 method-table-methods 889 7 ())
+(891 methods #f #f ())
+(892 method-table-prototype 891 7 ())
+(893 methods #f #f ())
+(894 make-generic 893 7 ())
+(895 methods #f #f ())
+(896 method-table-get-perform 895 7 ())
+(897 methods #f #f ())
+(898 method-table-set-perform! 897 7 ())
+(899 methods #f #f ())
+(900 method-table-id 899 7 ())
+(901 methods #f #f ())
+(902 really-make-method-table 901 7 ())
+(903 methods #f #f ())
+(904 methods #f #f ())
+(905 #f 904 11 ())
+(906 methods #f #f ())
+(907 method-info-types 906 7 ())
+(908 methods #f #f ())
+(909 method-info-n-ary? 908 7 ())
+(910 methods #f #f ())
+(911 method-info-proc 910 7 ())
+(912 methods #f #f ())
+(913 really-make-method-info 912 7 ())
+(914 methods #f #f ())
+(915 methods #f #f ())
+(916 record-type-priority 915 51 ())
+(917 methods #f #f ())
+(918 methods #f #f ())
+(919 methods #f #f ())
+(920 methods #f #f ())
+(921 methods #f #f ())
+(922 methods #f #f ())
+(923 methods #f #f ())
+(924 methods #f #f ())
+(925 methods #f #f ())
+(926 methods #f #f ())
+(927 methods #f #f ())
+(928 methods #f #f ())
+(929 methods #f #f ())
+(930 #f 929 25 ())
+(931 methods #f #f ())
+(932 methods #f #f ())
+(933 methods #f #f ())
+(934 methods #f #f ())
+(935 methods #f #f ())
+(936 methods #f #f ())
+(937 #f 936 25 ())
+(938 methods #f #f ())
+(939 methods #f #f ())
+(940 methods #f #f ())
+(941 methods #f #f ())
+(942 #f 941 11 ())
+(943 methods #f #f ())
+(944 simple-type-superiors 943 7 ())
+(945 methods #f #f ())
+(946 simple-type-predicate 945 7 ())
+(947 methods #f #f ())
+(948 simple-type-priority 947 7 ())
+(949 methods #f #f ())
+(950 simple-type-id 949 7 ())
+(951 methods #f #f ())
+(952 really-make-simple-type 951 7 ())
+(953 methods #f #f ())
+(954 methods #f #f ())
+(955 simple-type? 954 7 ())
+(956 methods #f #f ())
+(957 %type-priority 956 7 ())
+(958 methods #f #f ())
+(959 compute-priority 958 7 ())
+(960 methods #f #f ())
+(961 make-simple-type 960 7 ())
+(962 methods #f #f ())
+(963 %type-predicate 962 7 ())
+(964 methods #f #f ())
+(965 %same-type? 964 7 ())
+(966 methods #f #f ())
+(967 value? 966 7 ())
+(968 methods #f #f ())
+(969 method-info? 968 7 ())
+(970 methods #f #f ())
+(971 make-method-info 970 7 ())
+(972 methods #f #f ())
+(973 empty-method-list 972 7 ())
+(974 methods #f #f ())
+(975 more-specific-type? 974 7 ())
+(976 methods #f #f ())
+(977 more-specific? 976 7 ())
+(978 loop 977 148 ())
+(979 methods #f #f ())
+(980 every2 979 7 ())
+(981 methods #f #f ())
+(982 same-applicability? 981 7 ())
+(983 methods #f #f ())
+(984 insert-method 983 7 ())
+(985 recur 984 18 ())
+(986 methods #f #f ())
+(987 method-table? 986 7 ())
+(988 methods #f #f ())
+(989 last-action 988 7 ())
+(990 #f 989 6 ())
+(991 methods #f #f ())
+(992 one-action 991 7 ())
+(993 #f 992 6 ())
+(994 #f 993 20 ())
+(995 methods #f #f ())
+(996 check-for-next 995 7 ())
+(997 #f 996 6 ())
+(998 methods #f #f ())
+(999 check-next 998 7 ())
+(1000 #f 999 6 ())
+(1001 methods #f #f ())
+(1002 argument-sequence-predicate 1001 7 ())
+(1003 recur 1002 27 ())
+(1004 methods #f #f ())
+(1005 methods->perform 1004 7 ())
+(1006 recur 1005 18 ())
+(1007 methods #f #f ())
+(1008 add-to-method-table! 1007 7 ())
+(1009 methods #f #f ())
+(1010 set-final-method! 1009 7 ())
+(1011 methods #f #f ())
+(1012 make-cell-for-generic 1011 7 ())
+(1013 #f 1012 8 ())
+(1014 #f 1012 13 ())
+(1015 #f 1012 18 ())
+(1016 methods #f #f ())
+(1017 make-method-table 1016 7 ())
+(1018 #f 1017 53 ())
+(1019 #f 1017 79 ())
+(1020 methods #f #f ())
+(1021 apply-generic 1020 7 ())
+(1022 methods #f #f ())
+(1023 compare-to 1022 7 ())
+(1024 #f 1023 6 ())
+(1025 methods #f #f ())
+(1026 proc->discloser 1025 7 ())
+(1027 #f 1026 6 ())
+(1028 #f 1027 6 ())
+(1029 methods #f #f ())
+(1030 number-i/o #f #f ())
+(1031 string->integer 1030 24 ())
+(1032 do-it 1030 33 ())
+(1033 loop 1032 40 ())
+(1034 digit->integer 1030 42 ())
+(1035 number-i/o #f #f ())
+(1036 set-exactness 1035 7 ())
+(1037 number-i/o #f #f ())
+(1038 &really-string->number 1037 60 ())
+(1039 number-i/o #f #f ())
+(1040 #f 1039 25 ())
+(1041 loop 1040 31 ())
+(1042 number-i/o #f #f ())
+(1043 &really-string->number 1042 60 ())
+(1044 number-i/o #f #f ())
+(1045 number-i/o #f #f ())
+(1046 number-i/o #f #f ())
+(1047 string->number 1046 7 ())
+(1048 loop 1047 285 ())
+(1049 radix-is 1048 55 ())
+(1050 exactness-is 1048 60 ())
+(1051 loop 1048 300 ())
+(1052 number-i/o #f #f ())
+(1053 integer->string 1052 22 ())
+(1054 recur 1053 52 ())
+(1055 integer->digit 1052 31 ())
+(1056 number-i/o #f #f ())
+(1057 &number->string 1056 56 ())
+(1058 number-i/o #f #f ())
+(1059 &number->string 1058 56 ())
+(1060 number-i/o #f #f ())
+(1061 number->string 1060 7 ())
+(1062 number-i/o #f #f ())
+(1063 number-i/o #f #f ())
+(1064 fluids #f #f ())
+(1065 fluids #f #f ())
+(1066 set-fluid-top-level-value! 1065 7 ())
+(1067 fluids #f #f ())
+(1068 fluid-top-level-value 1067 7 ())
+(1069 fluids #f #f ())
+(1070 make-fluid 1069 7 ())
+(1071 fluids #f #f ())
+(1072 fluids #f #f ())
+(1073 thread-dynamic-env 1072 7 ())
+(1074 fluids #f #f ())
+(1075 thread-dynamic-point 1074 7 ())
+(1076 fluids #f #f ())
+(1077 make-thread 1076 7 ())
+(1078 fluids #f #f ())
+(1079 fluids #f #f ())
+(1080 get-dynamic-env 1079 7 ())
+(1081 fluids #f #f ())
+(1082 set-dynamic-env! 1081 7 ())
+(1083 fluids #f #f ())
+(1084 get-dynamic-point 1083 7 ())
+(1085 fluids #f #f ())
+(1086 set-dynamic-point! 1085 7 ())
+(1087 fluids #f #f ())
+(1088 empty-dynamic-env 1087 7 ())
+(1089 fluids #f #f ())
+(1090 initialize-dynamic-state! 1089 7 ())
+(1091 fluids #f #f ())
+(1092 with-dynamic-env 1091 7 ())
+(1093 #f 1092 38 ())
+(1094 fluids #f #f ())
+(1095 fluid 1094 7 ())
+(1096 fluids #f #f ())
+(1097 set-fluid! 1096 7 ())
+(1098 fluids #f #f ())
+(1099 let-fluid 1098 7 ())
+(1100 fluids #f #f ())
+(1101 let-fluids 1100 7 ())
+(1102 loop 1101 30 ())
+(1103 enumerated #f #f ())
+(1104 lookup-enumerand 1103 7 ())
+(1105 loop 1104 27 ())
+(1106 architecture #f #f ())
+(1107 architecture #f #f ())
+(1108 architecture #f #f ())
+(1109 architecture #f #f ())
+(1110 architecture #f #f ())
+(1111 architecture #f #f ())
+(1112 architecture #f #f ())
+(1113 architecture #f #f ())
+(1114 architecture #f #f ())
+(1115 architecture #f #f ())
+(1116 architecture #f #f ())
+(1117 architecture #f #f ())
+(1118 architecture #f #f ())
+(1119 architecture #f #f ())
+(1120 architecture #f #f ())
+(1121 architecture #f #f ())
+(1122 architecture #f #f ())
+(1123 architecture #f #f ())
+(1124 architecture #f #f ())
+(1125 architecture #f #f ())
+(1126 architecture #f #f ())
+(1127 architecture #f #f ())
+(1128 architecture #f #f ())
+(1129 next-protocol 1128 7 ())
+(1130 architecture #f #f ())
+(1131 architecture #f #f ())
+(1132 architecture #f #f ())
+(1133 architecture #f #f ())
+(1134 architecture #f #f ())
+(1135 architecture #f #f ())
+(1136 architecture #f #f ())
+(1137 architecture #f #f ())
+(1138 architecture #f #f ())
+(1139 architecture #f #f ())
+(1140 architecture #f #f ())
+(1141 architecture #f #f ())
+(1142 architecture #f #f ())
+(1143 architecture #f #f ())
+(1144 queues #f #f ())
+(1145 queue-uid 1144 7 ())
+(1146 queues #f #f ())
+(1147 set-queue-head! 1146 7 ())
+(1148 queues #f #f ())
+(1149 queue-head 1148 7 ())
+(1150 queues #f #f ())
+(1151 set-queue-tail! 1150 7 ())
+(1152 queues #f #f ())
+(1153 queue-tail 1152 7 ())
+(1154 queues #f #f ())
+(1155 really-make-queue 1154 7 ())
+(1156 queues #f #f ())
+(1157 queues #f #f ())
+(1158 queue? 1157 7 ())
+(1159 queues #f #f ())
+(1160 make-queue 1159 7 ())
+(1161 queues #f #f ())
+(1162 queue-empty? 1161 7 ())
+(1163 queues #f #f ())
+(1164 enqueue! 1163 7 ())
+(1165 queues #f #f ())
+(1166 queue-front 1165 7 ())
+(1167 queues #f #f ())
+(1168 dequeue! 1167 7 ())
+(1169 queues #f #f ())
+(1170 on-queue? 1169 7 ())
+(1171 queues #f #f ())
+(1172 delete-from-queue-if! 1171 7 ())
+(1173 loop 1172 130 ())
+(1174 queues #f #f ())
+(1175 delete-from-queue! 1174 7 ())
+(1176 #f 1175 9 ())
+(1177 queues #f #f ())
+(1178 queue->list 1177 7 ())
+(1179 #f 1178 6 ())
+(1180 queues #f #f ())
+(1181 queue-length 1180 7 ())
+(1182 queues #f #f ())
+(1183 conditions #f #f ())
+(1184 conditions #f #f ())
+(1185 conditions #f #f ())
+(1186 conditions #f #f ())
+(1187 conditions #f #f ())
+(1188 conditions #f #f ())
+(1189 conditions #f #f ())
+(1190 make-exception 1189 7 ())
+(1191 conditions #f #f ())
+(1192 conditions #f #f ())
+(1193 conditions #f #f ())
+(1194 conditions #f #f ())
+(1195 conditions #f #f ())
+(1196 conditions #f #f ())
+(1197 conditions #f #f ())
+(1198 conditions #f #f ())
+(1199 conditions #f #f ())
+(1200 conditions #f #f ())
+(1201 conditions #f #f ())
+(1202 conditions #f #f ())
+(1203 conditions #f #f ())
+(1204 conditions #f #f ())
+(1205 condition? 1204 7 ())
+(1206 conditions #f #f ())
+(1207 condition-predicate 1206 7 ())
+(1208 #f 1207 6 ())
+(1209 conditions #f #f ())
+(1210 define-condition-type 1209 7 ())
+(1211 #f 1210 17 ())
+(1212 conditions #f #f ())
+(1213 condition-supertypes 1212 7 ())
+(1214 conditions #f #f ())
+(1215 session-data #f #f ())
+(1216 make-session-data-slot! 1215 7 ())
+(1217 session-data #f #f ())
+(1218 session-data-ref 1217 7 ())
+(1219 session-data #f #f ())
+(1220 session-data-set! 1219 7 ())
+(1221 session-data #f #f ())
+(1222 initialize-session-data! 1221 7 ())
+(1223 session-data #f #f ())
+(1224 interrupts #f #f ())
+(1225 #f 1224 11 ())
+(1226 interrupts #f #f ())
+(1227 interrupts #f #f ())
+(1228 interrupts #f #f ())
+(1229 interrupts #f #f ())
+(1230 enabled-interrupts 1229 7 ())
+(1231 interrupts #f #f ())
+(1232 post-gc-handler 1231 7 ())
+(1233 #f 1232 6 ())
+(1234 #f 1233 42 ())
+(1235 #f 1233 58 ())
+(1236 #f 1235 7 ())
+(1237 #f 1235 21 ())
+(1238 interrupts #f #f ())
+(1239 initialize-interrupts! 1238 7 ())
+(1240 #f 1239 6 ())
+(1241 loop##72 1240 32 ())
+(1242 #f 1241 32 ())
+(1243 #f 1240 78 ())
+(1244 #f 1243 11 ())
+(1245 interrupts #f #f ())
+(1246 set-interrupt-handler! 1245 7 ())
+(1247 interrupts #f #f ())
+(1248 with-interrupts 1247 7 ())
+(1249 #f 1248 13 ())
+(1250 interrupts #f #f ())
+(1251 with-interrupts-inhibited 1250 7 ())
+(1252 interrupts #f #f ())
+(1253 with-interrupts-allowed 1252 7 ())
+(1254 interrupts #f #f ())
+(1255 disable-interrupts! 1254 7 ())
+(1256 interrupts #f #f ())
+(1257 enable-interrupts! 1256 7 ())
+(1258 interrupts #f #f ())
+(1259 call-after-gc! 1258 7 ())
+(1260 interrupts #f #f ())
+(1261 call-before-heap-overflow! 1260 7 ())
+(1262 interrupts #f #f ())
+(1263 interrupts #f #f ())
+(1264 wind #f #f ())
+(1265 point-depth 1264 7 ())
+(1266 wind #f #f ())
+(1267 point-in 1266 7 ())
+(1268 wind #f #f ())
+(1269 point-out 1268 7 ())
+(1270 wind #f #f ())
+(1271 point-dynamic-env 1270 7 ())
+(1272 wind #f #f ())
+(1273 point-parent 1272 7 ())
+(1274 wind #f #f ())
+(1275 make-point 1274 7 ())
+(1276 wind #f #f ())
+(1277 wind #f #f ())
+(1278 dynamic-wind 1277 7 ())
+(1279 wind #f #f ())
+(1280 travel-to-point! 1279 7 ())
+(1281 wind #f #f ())
+(1282 continuation->procedure 1281 7 ())
+(1283 #f 1282 6 ())
+(1284 #f 1283 60 ())
+(1285 wind #f #f ())
+(1286 call-with-current-continuation 1285 7 ())
+(1287 #f 1286 6 ())
+(1288 templates #f #f ())
+(1289 template-code 1288 7 ())
+(1290 templates #f #f ())
+(1291 template-info 1290 7 ())
+(1292 templates #f #f ())
+(1293 set-template-code! 1292 7 ())
+(1294 templates #f #f ())
+(1295 set-template-info! 1294 7 ())
+(1296 templates #f #f ())
+(1297 more-types #f #f ())
+(1298 &disclose 1297 48 ())
+(1299 more-types #f #f ())
+(1300 more-types #f #f ())
+(1301 &disclose 1300 52 ())
+(1302 more-types #f #f ())
+(1303 more-types #f #f ())
+(1304 more-types #f #f ())
+(1305 more-types #f #f ())
+(1306 more-types #f #f ())
+(1307 more-types #f #f ())
+(1308 more-types #f #f ())
+(1309 more-types #f #f ())
+(1310 continuations #f #f ())
+(1311 &disclose 1310 48 ())
+(1312 continuations #f #f ())
+(1313 continuations #f #f ())
+(1314 continuations #f #f ())
+(1315 continuation-cont 1314 7 ())
+(1316 continuations #f #f ())
+(1317 real-continuation-pc 1316 7 ())
+(1318 continuations #f #f ())
+(1319 real-continuation-template 1318 7 ())
+(1320 continuations #f #f ())
+(1321 continuation-env 1320 7 ())
+(1322 continuations #f #f ())
+(1323 exception-continuation-pc 1322 7 ())
+(1324 continuations #f #f ())
+(1325 exception-continuation-template 1324 7 ())
+(1326 continuations #f #f ())
+(1327 exception-continuation-exception 1326 7 ())
+(1328 continuations #f #f ())
+(1329 exception-continuation? 1328 7 ())
+(1330 continuations #f #f ())
+(1331 continuation-pc 1330 7 ())
+(1332 continuations #f #f ())
+(1333 continuation-template 1332 7 ())
+(1334 continuations #f #f ())
+(1335 continuation-arg 1334 7 ())
+(1336 continuations #f #f ())
+(1337 continuation-arg-count 1336 7 ())
+(1338 continuations #f #f ())
+(1339 continuation-parent 1338 7 ())
+(1340 loop 1339 105 ())
+(1341 continuations #f #f ())
+(1342 exceptions #f #f ())
+(1343 &disclose 1342 48 ())
+(1344 exceptions #f #f ())
+(1345 &disclose 1344 52 ())
+(1346 exceptions #f #f ())
+(1347 report-errors-as-warnings 1346 7 ())
+(1348 #f 1347 12 ())
+(1349 exceptions #f #f ())
+(1350 ignore-errors 1349 7 ())
+(1351 #f 1350 6 ())
+(1352 #f 1351 6 ())
+(1353 exceptions #f #f ())
+(1354 continuation-preview 1353 7 ())
+(1355 exceptions #f #f ())
+(1356 report-utter-lossage 1355 7 ())
+(1357 #f 1356 183 ())
+(1358 exceptions #f #f ())
+(1359 last-resort-condition-handler 1358 7 ())
+(1360 #f 1359 15 ())
+(1361 #f 1360 23 ())
+(1362 exceptions #f #f ())
+(1363 initialize-exceptions! 1362 7 ())
+(1364 #f 1363 6 ())
+(1365 exceptions #f #f ())
+(1366 exceptions #f #f ())
+(1367 with-handler 1366 7 ())
+(1368 exceptions #f #f ())
+(1369 really-signal-condition 1368 7 ())
+(1370 loop 1369 29 ())
+(1371 #f 1370 9 ())
+(1372 exceptions #f #f ())
+(1373 extend-opcode! 1372 7 ())
+(1374 except 1373 6 ())
+(1375 #f 1373 32 ())
+(1376 exceptions #f #f ())
+(1377 #f 1376 11 ())
+(1378 exceptions #f #f ())
+(1379 exceptions #f #f ())
+(1380 signal-exception 1379 7 ())
+(1381 exceptions #f #f ())
+(1382 define-exception-handler 1381 7 ())
+(1383 threads #f #f ())
+(1384 threads #f #f ())
+(1385 threads #f #f ())
+(1386 threads #f #f ())
+(1387 threads #f #f ())
+(1388 threads #f #f ())
+(1389 threads #f #f ())
+(1390 threads #f #f ())
+(1391 threads #f #f ())
+(1392 threads #f #f ())
+(1393 #f 1392 11 ())
+(1394 threads #f #f ())
+(1395 thread-dynamic-env 1394 7 ())
+(1396 threads #f #f ())
+(1397 set-thread-dynamic-point! 1396 7 ())
+(1398 threads #f #f ())
+(1399 thread-dynamic-point 1398 7 ())
+(1400 threads #f #f ())
+(1401 set-thread-continuation! 1400 7 ())
+(1402 threads #f #f ())
+(1403 thread-continuation 1402 7 ())
+(1404 threads #f #f ())
+(1405 set-thread-queue! 1404 7 ())
+(1406 threads #f #f ())
+(1407 thread-queue 1406 7 ())
+(1408 threads #f #f ())
+(1409 set-thread-arguments! 1408 7 ())
+(1410 threads #f #f ())
+(1411 thread-arguments 1410 7 ())
+(1412 threads #f #f ())
+(1413 set-thread-time! 1412 7 ())
+(1414 threads #f #f ())
+(1415 thread-time 1414 7 ())
+(1416 threads #f #f ())
+(1417 set-thread-scheduler! 1416 7 ())
+(1418 threads #f #f ())
+(1419 thread-scheduler 1418 7 ())
+(1420 threads #f #f ())
+(1421 set-thread-data! 1420 7 ())
+(1422 threads #f #f ())
+(1423 thread-data 1422 7 ())
+(1424 threads #f #f ())
+(1425 set-thread-events! 1424 7 ())
+(1426 threads #f #f ())
+(1427 thread-events 1426 7 ())
+(1428 threads #f #f ())
+(1429 set-thread-current-task! 1428 7 ())
+(1430 threads #f #f ())
+(1431 thread-current-task 1430 7 ())
+(1432 threads #f #f ())
+(1433 thread-uid 1432 7 ())
+(1434 threads #f #f ())
+(1435 thread-name 1434 7 ())
+(1436 threads #f #f ())
+(1437 really-make-thread 1436 7 ())
+(1438 threads #f #f ())
+(1439 threads #f #f ())
+(1440 thread? 1439 7 ())
+(1441 threads #f #f ())
+(1442 compose-continuation 1441 7 ())
+(1443 #f 1442 6 ())
+(1444 #f 1443 27 ())
+(1445 #f 1444 10 ())
+(1446 #f 1445 9 ())
+(1447 threads #f #f ())
+(1448 thunk->continuation 1447 7 ())
+(1449 threads #f #f ())
+(1450 interrupt-timer-time 1449 7 ())
+(1451 threads #f #f ())
+(1452 debit-down! 1451 7 ())
+(1453 loop 1452 28 ())
+(1454 threads #f #f ())
+(1455 run-thread 1454 7 ())
+(1456 #f 1455 44 ())
+(1457 threads #f #f ())
+(1458 switch-to-thread 1457 7 ())
+(1459 #f 1458 6 ())
+(1460 threads #f #f ())
+(1461 suspend-to 1460 7 ())
+(1462 threads #f #f ())
+(1463 suspend 1462 7 ())
+(1464 threads #f #f ())
+(1465 thread-top-level 1464 7 ())
+(1466 thread-start 1465 6 ())
+(1467 #f 1466 3 ())
+(1468 threads #f #f ())
+(1469 make-thread 1468 7 ())
+(1470 threads #f #f ())
+(1471 all-threads 1470 7 ())
+(1472 threads #f #f ())
+(1473 thread-uid->thread 1472 7 ())
+(1474 loop 1473 27 ())
+(1475 threads #f #f ())
+(1476 add-event! 1475 7 ())
+(1477 threads #f #f ())
+(1478 enqueue-thread! 1477 7 ())
+(1479 threads #f #f ())
+(1480 dequeue-thread! 1479 7 ())
+(1481 threads #f #f ())
+(1482 remove-thread-from-queue! 1481 7 ())
+(1483 threads #f #f ())
+(1484 event-pending? 1483 7 ())
+(1485 threads #f #f ())
+(1486 min 1485 7 ())
+(1487 threads #f #f ())
+(1488 schedule-interrupt! 1487 7 ())
+(1489 threads #f #f ())
+(1490 run-next-thread 1489 7 ())
+(1491 threads #f #f ())
+(1492 debit-thread-times-and-run! 1491 7 ())
+(1493 loop 1492 41 ())
+(1494 threads #f #f ())
+(1495 find-and-run-next-thread 1494 7 ())
+(1496 loop 1495 35 ())
+(1497 threads #f #f ())
+(1498 run 1497 7 ())
+(1499 threads #f #f ())
+(1500 handle-timer-interrupt 1499 7 ())
+(1501 threads #f #f ())
+(1502 exit 1501 7 ())
+(1503 threads #f #f ())
+(1504 wait 1503 7 ())
+(1505 threads #f #f ())
+(1506 waiting? 1505 7 ())
+(1507 threads #f #f ())
+(1508 block 1507 7 ())
+(1509 threads #f #f ())
+(1510 relinquish-timeslice 1509 7 ())
+(1511 threads #f #f ())
+(1512 running? 1511 7 ())
+(1513 loop 1512 25 ())
+(1514 threads #f #f ())
+(1515 interrupt-thread 1514 7 ())
+(1516 threads #f #f ())
+(1517 propogate-upcall 1516 7 ())
+(1518 #f 1517 62 ())
+(1519 threads #f #f ())
+(1520 upcall 1519 7 ())
+(1521 threads #f #f ())
+(1522 kill-thread! 1521 7 ())
+(1523 #f 1522 9 ())
+(1524 threads #f #f ())
+(1525 get-next-event! 1524 7 ())
+(1526 threads #f #f ())
+(1527 schedule-wakeup 1526 7 ())
+(1528 threads #f #f ())
+(1529 schedule-event 1528 7 ())
+(1530 threads #f #f ())
+(1531 show-running 1530 7 ())
+(1532 loop##111 1531 16 ())
+(1533 threads #f #f ())
+(1534 spawn-on-scheduler 1533 7 ())
+(1535 threads #f #f ())
+(1536 spawn 1535 7 ())
+(1537 threads #f #f ())
+(1538 root-scheduler 1537 7 ())
+(1539 threads #f #f ())
+(1540 spawn-on-root 1539 7 ())
+(1541 threads #f #f ())
+(1542 make-ready 1541 7 ())
+(1543 threads #f #f ())
+(1544 cancel-timer-interrupt! 1543 7 ())
+(1545 threads #f #f ())
+(1546 real-time 1545 7 ())
+(1547 threads #f #f ())
+(1548 start-multitasking 1547 7 ())
+(1549 #f 1548 6 ())
+(1550 #f 1549 6 ())
+(1551 #f 1549 11 ())
+(1552 #f 1551 7 ())
+(1553 #f 1552 6 ())
+(1554 #f 1552 11 ())
+(1555 threads #f #f ())
+(1556 with-threads 1555 7 ())
+(1557 #f 1556 10 ())
+(1558 #f 1557 3 ())
+(1559 #f 1557 8 ())
+(1560 #f 1557 13 ())
+(1561 threads #f #f ())
+(1562 terminate-current-thread 1561 7 ())
+(1563 threads #f #f ())
+(1564 insert 1563 7 ())
+(1565 threads #f #f ())
+(1566 sleep 1565 7 ())
+(1567 #f 1566 71 ())
+(1568 threads #f #f ())
+(1569 wake-some-threads 1568 7 ())
+(1570 loop 1569 46 ())
+(1571 threads #f #f ())
+(1572 threads #f #f ())
+(1573 threads #f #f ())
+(1574 threads #f #f ())
+(1575 locks #f #f ())
+(1576 set-lock-owner-uid! 1575 7 ())
+(1577 locks #f #f ())
+(1578 lock-owner-uid 1577 7 ())
+(1579 locks #f #f ())
+(1580 lock-queue 1579 7 ())
+(1581 locks #f #f ())
+(1582 lock-uid 1581 7 ())
+(1583 locks #f #f ())
+(1584 really-make-lock 1583 7 ())
+(1585 locks #f #f ())
+(1586 locks #f #f ())
+(1587 lock? 1586 7 ())
+(1588 locks #f #f ())
+(1589 make-lock 1588 7 ())
+(1590 locks #f #f ())
+(1591 obtain-lock 1590 7 ())
+(1592 #f 1591 10 ())
+(1593 locks #f #f ())
+(1594 maybe-obtain-lock 1593 7 ())
+(1595 #f 1594 10 ())
+(1596 locks #f #f ())
+(1597 release-lock 1596 7 ())
+(1598 #f 1597 10 ())
+(1599 locks #f #f ())
+(1600 i/o #f #f ())
+(1601 i/o #f #f ())
+(1602 i/o #f #f ())
+(1603 i/o #f #f ())
+(1604 #f 1603 11 ())
+(1605 #f 1603 16 ())
+(1606 #f 1603 21 ())
+(1607 i/o #f #f ())
+(1608 i/o #f #f ())
+(1609 i/o #f #f ())
+(1610 i/o #f #f ())
+(1611 i/o #f #f ())
+(1612 i/o #f #f ())
+(1613 i/o #f #f ())
+(1614 i/o #f #f ())
+(1615 i/o #f #f ())
+(1616 i/o #f #f ())
+(1617 &disclose 1616 52 ())
+(1618 i/o #f #f ())
+(1619 &disclose 1618 52 ())
+(1620 i/o #f #f ())
+(1621 port-handler-discloser 1620 7 ())
+(1622 i/o #f #f ())
+(1623 port-handler-close 1622 7 ())
+(1624 i/o #f #f ())
+(1625 port-handler-buffer-proc 1624 7 ())
+(1626 i/o #f #f ())
+(1627 make-port-handler 1626 7 ())
+(1628 i/o #f #f ())
+(1629 i/o #f #f ())
+(1630 port-handler? 1629 7 ())
+(1631 i/o #f #f ())
+(1632 disclose-port 1631 7 ())
+(1633 i/o #f #f ())
+(1634 obtain-port-lock 1633 7 ())
+(1635 i/o #f #f ())
+(1636 maybe-obtain-port-lock 1635 7 ())
+(1637 i/o #f #f ())
+(1638 release-port-lock 1637 7 ())
+(1639 i/o #f #f ())
+(1640 one-arg-proc->handler 1639 7 ())
+(1641 #f 1640 6 ())
+(1642 i/o #f #f ())
+(1643 fill-port-buffer! 1642 7 ())
+(1644 i/o #f #f ())
+(1645 read-char-handler 1644 7 ())
+(1646 #f 1645 6 ())
+(1647 i/o #f #f ())
+(1648 two-arg-proc->handler 1647 7 ())
+(1649 #f 1648 6 ())
+(1650 i/o #f #f ())
+(1651 empty-port-buffer! 1650 7 ())
+(1652 i/o #f #f ())
+(1653 write-char-handler 1652 7 ())
+(1654 i/o #f #f ())
+(1655 initialize-i/o-handlers! 1654 7 ())
+(1656 i/o #f #f ())
+(1657 open-input-port? 1656 7 ())
+(1658 i/o #f #f ())
+(1659 make-input-port-closed! 1658 7 ())
+(1660 i/o #f #f ())
+(1661 close-input-port 1660 7 ())
+(1662 i/o #f #f ())
+(1663 open-output-port? 1662 7 ())
+(1664 i/o #f #f ())
+(1665 really-force-output 1664 7 ())
+(1666 i/o #f #f ())
+(1667 make-output-port-closed! 1666 7 ())
+(1668 i/o #f #f ())
+(1669 close-output-port 1668 7 ())
+(1670 i/o #f #f ())
+(1671 open-port? 1670 7 ())
+(1672 i/o #f #f ())
+(1673 current-input-port 1672 7 ())
+(1674 i/o #f #f ())
+(1675 input-port-option 1674 7 ())
+(1676 i/o #f #f ())
+(1677 char-ready? 1676 7 ())
+(1678 i/o #f #f ())
+(1679 real-char-ready? 1678 7 ())
+(1680 i/o #f #f ())
+(1681 okay-limits? 1680 7 ())
+(1682 i/o #f #f ())
+(1683 read-more 1682 7 ())
+(1684 i/o #f #f ())
+(1685 buffer-length 1684 7 ())
+(1686 i/o #f #f ())
+(1687 really-read-block 1686 7 ())
+(1688 i/o #f #f ())
+(1689 read-block 1688 7 ())
+(1690 i/o #f #f ())
+(1691 write-unbuffered-block 1690 7 ())
+(1692 loop##127 1691 40 ())
+(1693 i/o #f #f ())
+(1694 write-buffered-block 1693 7 ())
+(1695 i/o #f #f ())
+(1696 write-block 1695 7 ())
+(1697 i/o #f #f ())
+(1698 write-string 1697 7 ())
+(1699 i/o #f #f ())
+(1700 force-output 1699 7 ())
+(1701 i/o #f #f ())
+(1702 force-output-if-open 1701 7 ())
+(1703 i/o #f #f ())
+(1704 okay-buffer? 1703 7 ())
+(1705 i/o #f #f ())
+(1706 make-input-port 1705 7 ())
+(1707 i/o #f #f ())
+(1708 make-output-port 1707 7 ())
+(1709 i/o #f #f ())
+(1710 make-unbuffered-output-port 1709 7 ())
+(1711 i/o #f #f ())
+(1712 make-null-output-port 1711 7 ())
+(1713 i/o #f #f ())
+(1714 initialize-output-port-list! 1713 7 ())
+(1715 i/o #f #f ())
+(1716 periodically-force-output! 1715 7 ())
+(1717 i/o #f #f ())
+(1718 make-forcing-thunk 1717 7 ())
+(1719 #f 1718 6 ())
+(1720 #f 1719 7 ())
+(1721 #f 1719 46 ())
+(1722 i/o #f #f ())
+(1723 output-port-forcers 1722 7 ())
+(1724 loop 1723 30 ())
+(1725 i/o #f #f ())
+(1726 periodically-flushed-ports 1725 7 ())
+(1727 loop 1726 35 ())
+(1728 i/o #f #f ())
+(1729 current-output-port 1728 7 ())
+(1730 i/o #f #f ())
+(1731 current-error-port 1730 7 ())
+(1732 i/o #f #f ())
+(1733 current-noise-port 1732 7 ())
+(1734 i/o #f #f ())
+(1735 with-current-ports 1734 7 ())
+(1736 i/o #f #f ())
+(1737 initialize-i/o 1736 7 ())
+(1738 i/o #f #f ())
+(1739 call-with-current-input-port 1738 7 ())
+(1740 i/o #f #f ())
+(1741 call-with-current-output-port 1740 7 ())
+(1742 i/o #f #f ())
+(1743 call-with-current-noise-port 1742 7 ())
+(1744 i/o #f #f ())
+(1745 silently 1744 7 ())
+(1746 i/o #f #f ())
+(1747 output-port-option 1746 7 ())
+(1748 i/o #f #f ())
+(1749 newline 1748 7 ())
+(1750 i/o #f #f ())
+(1751 i/o #f #f ())
+(1752 i/o #f #f ())
+(1753 writing #f #f ())
+(1754 display 1753 7 ())
+(1755 recur 1754 36 ())
+(1756 writing #f #f ())
+(1757 display-type-name 1756 7 ())
+(1758 loop##133 1757 90 ())
+(1759 writing #f #f ())
+(1760 write-other 1759 7 ())
+(1761 #f 1760 73 ())
+(1762 writing #f #f ())
+(1763 write-vector 1762 7 ())
+(1764 loop 1763 76 ())
+(1765 writing #f #f ())
+(1766 quotation? 1765 7 ())
+(1767 writing #f #f ())
+(1768 write-list 1767 7 ())
+(1769 loop 1768 92 ())
+(1770 writing #f #f ())
+(1771 write-string-literal 1770 7 ())
+(1772 loop##137 1771 26 ())
+(1773 writing #f #f ())
+(1774 character-name 1773 7 ())
+(1775 writing #f #f ())
+(1776 write-char-literal 1775 7 ())
+(1777 writing #f #f ())
+(1778 write-number 1777 7 ())
+(1779 writing #f #f ())
+(1780 write-boolean 1779 7 ())
+(1781 writing #f #f ())
+(1782 recurring-write 1781 7 ())
+(1783 writing #f #f ())
+(1784 write 1783 7 ())
+(1785 recur 1784 36 ())
+(1786 reading #f #f ())
+(1787 loop##139 1786 40 ())
+(1788 reading #f #f ())
+(1789 reading #f #f ())
+(1790 number-sharp-macro 1789 7 ())
+(1791 #f 1789 15 ())
+(1792 reading #f #f ())
+(1793 #f 1792 11 ())
+(1794 reading #f #f ())
+(1795 #f 1794 11 ())
+(1796 reading #f #f ())
+(1797 #f 1796 11 ())
+(1798 reading #f #f ())
+(1799 #f 1798 11 ())
+(1800 reading #f #f ())
+(1801 #f 1800 13 ())
+(1802 reading #f #f ())
+(1803 #f 1802 15 ())
+(1804 reading #f #f ())
+(1805 #f 1804 15 ())
+(1806 loop 1805 25 ())
+(1807 reading #f #f ())
+(1808 #f 1807 15 ())
+(1809 reading #f #f ())
+(1810 #f 1809 15 ())
+(1811 reading #f #f ())
+(1812 #f 1811 15 ())
+(1813 reading #f #f ())
+(1814 #f 1813 15 ())
+(1815 reading #f #f ())
+(1816 reading #f #f ())
+(1817 sub-read-constituent 1816 7 ())
+(1818 #f 1816 15 ())
+(1819 reading #f #f ())
+(1820 sub-read-whitespace 1819 7 ())
+(1821 #f 1819 15 ())
+(1822 reading #f #f ())
+(1823 reading #f #f ())
+(1824 #f 1823 11 ())
+(1825 reading #f #f ())
+(1826 reading #f #f ())
+(1827 reading #f #f ())
+(1828 reading #f #f ())
+(1829 reader-token? 1828 7 ())
+(1830 reading #f #f ())
+(1831 reading-error 1830 7 ())
+(1832 reading #f #f ())
+(1833 sub-read 1832 7 ())
+(1834 reading #f #f ())
+(1835 read 1834 7 ())
+(1836 loop 1835 33 ())
+(1837 reading #f #f ())
+(1838 sub-read-carefully 1837 7 ())
+(1839 reading #f #f ())
+(1840 make-reader-token 1839 7 ())
+(1841 reading #f #f ())
+(1842 set-standard-syntax! 1841 7 ())
+(1843 reading #f #f ())
+(1844 set-standard-read-macro! 1843 7 ())
+(1845 reading #f #f ())
+(1846 sub-read-list 1845 7 ())
+(1847 recur 1846 56 ())
+(1848 reading #f #f ())
+(1849 gobble-line 1848 7 ())
+(1850 loop 1849 15 ())
+(1851 reading #f #f ())
+(1852 define-sharp-macro 1851 7 ())
+(1853 reading #f #f ())
+(1854 preferred-case 1853 7 ())
+(1855 reading #f #f ())
+(1856 sub-read-token 1855 7 ())
+(1857 loop 1856 42 ())
+(1858 reading #f #f ())
+(1859 parse-token 1858 7 ())
+(1860 reading #f #f ())
+(1861 reading #f #f ())
+(1862 channels #f #f ())
+(1863 close-output-channel 1862 7 ())
+(1864 channels #f #f ())
+(1865 close-input-channel 1864 7 ())
+(1866 channels #f #f ())
+(1867 open-output-channel 1866 7 ())
+(1868 channels #f #f ())
+(1869 open-input-channel 1868 7 ())
+(1870 channels #f #f ())
+(1871 output-channel? 1870 7 ())
+(1872 channels #f #f ())
+(1873 input-channel? 1872 7 ())
+(1874 channel-i/o #f #f ())
+(1875 fetch-channel-wait-queue! 1874 7 ())
+(1876 loop 1875 113 ())
+(1877 channel-i/o #f #f ())
+(1878 add-channel-wait-queue! 1877 7 ())
+(1879 channel-i/o #f #f ())
+(1880 channel-i/o #f #f ())
+(1881 decrement-channel-wait-count! 1880 7 ())
+(1882 channel-i/o #f #f ())
+(1883 increment-channel-wait-count! 1882 7 ())
+(1884 channel-i/o #f #f ())
+(1885 channel-wait-count 1884 7 ())
+(1886 channel-i/o #f #f ())
+(1887 channel-i/o #f #f ())
+(1888 #f 1887 11 ())
+(1889 channel-i/o #f #f ())
+(1890 #f 1889 11 ())
+(1891 channel-i/o #f #f ())
+(1892 steal-channel! 1891 7 ())
+(1893 channel-i/o #f #f ())
+(1894 nothing 1893 7 ())
+(1895 channel-i/o #f #f ())
+(1896 wait-for-channel 1895 7 ())
+(1897 #f 1896 135 ())
+(1898 channel-i/o #f #f ())
+(1899 waiting-for-i/o? 1898 7 ())
+(1900 channel-i/o #f #f ())
+(1901 i/o-completion-handler 1900 7 ())
+(1902 channel-i/o #f #f ())
+(1903 initialize-channel-i/o! 1902 7 ())
+(1904 channel-i/o #f #f ())
+(1905 really-steal-channel-port! 1904 7 ())
+(1906 #f 1905 154 ())
+(1907 channel-i/o #f #f ())
+(1908 steal-channel-port! 1907 7 ())
+(1909 channel-i/o #f #f ())
+(1910 force-channel-output-ports! 1909 7 ())
+(1911 #f 1910 3 ())
+(1912 channel-i/o #f #f ())
+(1913 with-output-to-file 1912 7 ())
+(1914 #f 1913 9 ())
+(1915 channel-i/o #f #f ())
+(1916 with-input-from-file 1915 7 ())
+(1917 #f 1916 9 ())
+(1918 channel-i/o #f #f ())
+(1919 call-with-output-file 1918 7 ())
+(1920 channel-i/o #f #f ())
+(1921 call-with-input-file 1920 7 ())
+(1922 channel-i/o #f #f ())
+(1923 open-output-file 1922 7 ())
+(1924 channel-i/o #f #f ())
+(1925 open-input-file 1924 7 ())
+(1926 channel-i/o #f #f ())
+(1927 port->channel 1926 7 ())
+(1928 channel-i/o #f #f ())
+(1929 channel-cell? 1928 7 ())
+(1930 channel-i/o #f #f ())
+(1931 channel-cell-ref 1930 7 ())
+(1932 channel-i/o #f #f ())
+(1933 channel-cell-closer 1932 7 ())
+(1934 channel-i/o #f #f ())
+(1935 make-channel-cell 1934 7 ())
+(1936 channel-i/o #f #f ())
+(1937 channel-i/o #f #f ())
+(1938 maybe-force-output 1937 7 ())
+(1939 #f 1938 28 ())
+(1940 channel-i/o #f #f ())
+(1941 real-output-channel->port 1940 7 ())
+(1942 channel-i/o #f #f ())
+(1943 output-channel+closer->port 1942 7 ())
+(1944 channel-i/o #f #f ())
+(1945 output-channel->port 1944 7 ())
+(1946 channel-i/o #f #f ())
+(1947 make-unbuffered-output-channel-handler 1946 7 ())
+(1948 #f 1947 19 ())
+(1949 #f 1947 24 ())
+(1950 #f 1947 29 ())
+(1951 channel-i/o #f #f ())
+(1952 #f 1951 11 ())
+(1953 #f 1951 16 ())
+(1954 #f 1951 21 ())
+(1955 channel-i/o #f #f ())
+(1956 real-input-channel->port 1955 7 ())
+(1957 channel-i/o #f #f ())
+(1958 input-channel+closer->port 1957 7 ())
+(1959 channel-i/o #f #f ())
+(1960 input-channel->port 1959 7 ())
+(1961 channel-i/o #f #f ())
+(1962 #f 1961 11 ())
+(1963 #f 1961 16 ())
+(1964 #f 1961 21 ())
+(1965 scheme-level-2 #f #f ())
+(1966 features #f #f ())
+(1967 tables #f #f ())
+(1968 tables #f #f ())
+(1969 tables #f #f ())
+(1970 tables #f #f ())
+(1971 make-table 1970 32 ())
+(1972 tables #f #f ())
+(1973 tables #f #f ())
+(1974 tables #f #f ())
+(1975 tables #f #f ())
+(1976 tables #f #f ())
+(1977 set-table-size! 1976 7 ())
+(1978 tables #f #f ())
+(1979 table-size 1978 7 ())
+(1980 tables #f #f ())
+(1981 set-table-data! 1980 7 ())
+(1982 tables #f #f ())
+(1983 table-data 1982 7 ())
+(1984 tables #f #f ())
+(1985 set-table-ref-procedure! 1984 7 ())
+(1986 tables #f #f ())
+(1987 table-ref-procedure 1986 7 ())
+(1988 tables #f #f ())
+(1989 set-table-set!-procedure! 1988 7 ())
+(1990 tables #f #f ())
+(1991 table-set!-procedure 1990 7 ())
+(1992 tables #f #f ())
+(1993 really-make-table 1992 7 ())
+(1994 tables #f #f ())
+(1995 tables #f #f ())
+(1996 table? 1995 7 ())
+(1997 tables #f #f ())
+(1998 table-ref 1997 7 ())
+(1999 tables #f #f ())
+(2000 table-set! 1999 7 ())
+(2001 tables #f #f ())
+(2002 next-table-size 2001 7 ())
+(2003 tables #f #f ())
+(2004 delete-entry! 2003 7 ())
+(2005 loop 2004 40 ())
+(2006 tables #f #f ())
+(2007 new-entry 2006 7 ())
+(2008 tables #f #f ())
+(2009 make-linear-table-set! 2008 7 ())
+(2010 #f 2009 6 ())
+(2011 tables #f #f ())
+(2012 table-expand-table! 2011 7 ())
+(2013 tables #f #f ())
+(2014 table-enter-alist! 2013 7 ())
+(2015 loop##166 2014 26 ())
+(2016 tables #f #f ())
+(2017 make-hash-table-ref 2016 7 ())
+(2018 #f 2017 6 ())
+(2019 tables #f #f ())
+(2020 expand-hash-table! 2019 7 ())
+(2021 loop##168 2020 52 ())
+(2022 tables #f #f ())
+(2023 make-hash-table-set! 2022 7 ())
+(2024 #f 2023 6 ())
+(2025 tables #f #f ())
+(2026 make->hash-table 2025 7 ())
+(2027 #f 2026 41 ())
+(2028 tables #f #f ())
+(2029 make-linear-table-ref 2028 7 ())
+(2030 #f 2029 6 ())
+(2031 tables #f #f ())
+(2032 assoc->table-maker 2031 7 ())
+(2033 #f 2032 60 ())
+(2034 tables #f #f ())
+(2035 make-assoc 2034 7 ())
+(2036 #f 2035 20 ())
+(2037 loop 2036 18 ())
+(2038 tables #f #f ())
+(2039 make-table-maker 2038 7 ())
+(2040 tables #f #f ())
+(2041 alist-walk 2040 7 ())
+(2042 loop##170 2041 11 ())
+(2043 tables #f #f ())
+(2044 really-table-walk 2043 7 ())
+(2045 loop##173 2044 63 ())
+(2046 tables #f #f ())
+(2047 table-walk 2046 7 ())
+(2048 #f 2047 6 ())
+(2049 tables #f #f ())
+(2050 make-table-immutable! 2049 7 ())
+(2051 tables #f #f ())
+(2052 table->entry-list 2051 7 ())
+(2053 #f 2052 17 ())
+(2054 tables #f #f ())
+(2055 default-table-hash-function 2054 7 ())
+(2056 tables #f #f ())
+(2057 default-table-assoc 2056 7 ())
+(2058 tables #f #f ())
+(2059 symbol-hash 2058 7 ())
+(2060 tables #f #f ())
+(2061 tables #f #f ())
+(2062 weak #f #f ())
+(2063 walk-population 2062 7 ())
+(2064 #f 2063 6 ())
+(2065 weak #f #f ())
+(2066 population->list 2065 7 ())
+(2067 weak #f #f ())
+(2068 population-reduce 2067 7 ())
+(2069 loop##175 2068 11 ())
+(2070 weak #f #f ())
+(2071 weak-memq 2070 7 ())
+(2072 weak #f #f ())
+(2073 add-to-population! 2072 7 ())
+(2074 weak #f #f ())
+(2075 make-population 2074 7 ())
+(2076 meta-types #f #f ())
+(2077 meta-types #f #f ())
+(2078 meta-types #f #f ())
+(2079 meta-types #f #f ())
+(2080 meta-types #f #f ())
+(2081 meta-types #f #f ())
+(2082 meta-types #f #f ())
+(2083 meta-types #f #f ())
+(2084 meta-types #f #f ())
+(2085 meta-types #f #f ())
+(2086 meta-types #f #f ())
+(2087 meta-types #f #f ())
+(2088 meta-types #f #f ())
+(2089 meta-types #f #f ())
+(2090 meta-types #f #f ())
+(2091 meta-types #f #f ())
+(2092 meta-types #f #f ())
+(2093 meta-types #f #f ())
+(2094 meta-types #f #f ())
+(2095 meta-types #f #f ())
+(2096 meta-types #f #f ())
+(2097 meta-types #f #f ())
+(2098 meta-types #f #f ())
+(2099 meta-types #f #f ())
+(2100 meta-types #f #f ())
+(2101 meta-types #f #f ())
+(2102 meta-types #f #f ())
+(2103 meta-types #f #f ())
+(2104 meta-types #f #f ())
+(2105 meta-types #f #f ())
+(2106 loop 2105 28 ())
+(2107 meta-types #f #f ())
+(2108 meta-types #f #f ())
+(2109 meta-types #f #f ())
+(2110 meta-types #f #f ())
+(2111 meta-types #f #f ())
+(2112 meta-types #f #f ())
+(2113 meta-types #f #f ())
+(2114 meta-types #f #f ())
+(2115 meta-types #f #f ())
+(2116 meta-types #f #f ())
+(2117 meta-types #f #f ())
+(2118 meta-types #f #f ())
+(2119 meta-types #f #f ())
+(2120 meta-types #f #f ())
+(2121 meta-types #f #f ())
+(2122 meta-types #f #f ())
+(2123 meta-types #f #f ())
+(2124 meta-types #f #f ())
+(2125 meta-types #f #f ())
+(2126 meta-types #f #f ())
+(2127 #f 2126 11 ())
+(2128 meta-types #f #f ())
+(2129 type-mask 2128 7 ())
+(2130 meta-types #f #f ())
+(2131 type-more 2130 7 ())
+(2132 meta-types #f #f ())
+(2133 type-info 2132 7 ())
+(2134 meta-types #f #f ())
+(2135 really-make-type 2134 7 ())
+(2136 meta-types #f #f ())
+(2137 meta-types #f #f ())
+(2138 meta-type? 2137 7 ())
+(2139 meta-types #f #f ())
+(2140 make-type 2139 7 ())
+(2141 meta-types #f #f ())
+(2142 set-type-name! 2141 7 ())
+(2143 meta-types #f #f ())
+(2144 make-other-type 2143 7 ())
+(2145 meta-types #f #f ())
+(2146 name->type 2145 7 ())
+(2147 meta-types #f #f ())
+(2148 new-type-bit 2147 7 ())
+(2149 meta-types #f #f ())
+(2150 mask->type 2149 7 ())
+(2151 meta-types #f #f ())
+(2152 bottom-type? 2151 7 ())
+(2153 meta-types #f #f ())
+(2154 new-atomic-type 2153 7 ())
+(2155 meta-types #f #f ())
+(2156 named-atomic-type 2155 7 ())
+(2157 meta-types #f #f ())
+(2158 empty-rail-type? 2157 7 ())
+(2159 meta-types #f #f ())
+(2160 rest-type? 2159 7 ())
+(2161 meta-types #f #f ())
+(2162 same-type? 2161 7 ())
+(2163 meta-types #f #f ())
+(2164 head-type 2163 7 ())
+(2165 meta-types #f #f ())
+(2166 optional-type? 2165 7 ())
+(2167 meta-types #f #f ())
+(2168 rail-type 2167 7 ())
+(2169 meta-types #f #f ())
+(2170 make-optional-type 2169 7 ())
+(2171 meta-types #f #f ())
+(2172 make-rest-type 2171 7 ())
+(2173 meta-types #f #f ())
+(2174 head-type-really 2173 7 ())
+(2175 meta-types #f #f ())
+(2176 tail-type 2175 7 ())
+(2177 meta-types #f #f ())
+(2178 value-type? 2177 7 ())
+(2179 meta-types #f #f ())
+(2180 other-type-info 2179 7 ())
+(2181 meta-types #f #f ())
+(2182 restrictive? 2181 7 ())
+(2183 meta-types #f #f ())
+(2184 make-procedure-type 2183 7 ())
+(2185 meta-types #f #f ())
+(2186 procedure-type-domain 2185 7 ())
+(2187 meta-types #f #f ())
+(2188 procedure-type-codomain 2187 7 ())
+(2189 meta-types #f #f ())
+(2190 meet-procedure 2189 7 ())
+(2191 meta-types #f #f ())
+(2192 meet-rail 2191 7 ())
+(2193 meta-types #f #f ())
+(2194 meet-type 2193 7 ())
+(2195 meta-types #f #f ())
+(2196 subtype? 2195 7 ())
+(2197 meta-types #f #f ())
+(2198 meet-procedure? 2197 7 ())
+(2199 meta-types #f #f ())
+(2200 meet? 2199 7 ())
+(2201 meta-types #f #f ())
+(2202 procedure-type? 2201 7 ())
+(2203 meta-types #f #f ())
+(2204 join-procedure 2203 7 ())
+(2205 meta-types #f #f ())
+(2206 join-rail 2205 7 ())
+(2207 meta-types #f #f ())
+(2208 join-type 2207 7 ())
+(2209 meta-types #f #f ())
+(2210 procedure-type 2209 7 ())
+(2211 meta-types #f #f ())
+(2212 sexp->values-type 2211 7 ())
+(2213 meta-types #f #f ())
+(2214 sexp->type 2213 7 ())
+(2215 #f 2214 285 ())
+(2216 #f 2214 349 ())
+(2217 meta-types #f #f ())
+(2218 disjoin-rest 2217 7 ())
+(2219 meta-types #f #f ())
+(2220 disjoin-type 2219 7 ())
+(2221 loop##194 2220 262 ())
+(2222 meta-types #f #f ())
+(2223 atomic-type->sexp 2222 7 ())
+(2224 meta-types #f #f ())
+(2225 rail-type->sexp 2224 7 ())
+(2226 recur 2225 25 ())
+(2227 meta-types #f #f ())
+(2228 type->sexp 2227 7 ())
+(2229 #f 2228 141 ())
+(2230 meta-types #f #f ())
+(2231 make-some-values-type 2230 7 ())
+(2232 meta-types #f #f ())
+(2233 fixed-arity-procedure-type? 2232 7 ())
+(2234 loop 2233 43 ())
+(2235 meta-types #f #f ())
+(2236 procedure-type-arity 2235 7 ())
+(2237 loop##197 2236 11 ())
+(2238 meta-types #f #f ())
+(2239 procedure-type-argument-types 2238 7 ())
+(2240 recur 2239 28 ())
+(2241 meta-types #f #f ())
+(2242 variable-type 2241 7 ())
+(2243 meta-types #f #f ())
+(2244 variable-type? 2243 7 ())
+(2245 meta-types #f #f ())
+(2246 compatible-types? 2245 7 ())
+(2247 meta-types #f #f ())
+(2248 meta-types #f #f ())
+(2249 meta-types #f #f ())
+(2250 interfaces #f #f ())
+(2251 #f 2250 7 ())
+(2252 interfaces #f #f ())
+(2253 ref-method 2252 7 ())
+(2254 interfaces #f #f ())
+(2255 walk-method 2254 7 ())
+(2256 interfaces #f #f ())
+(2257 interface-clients 2256 7 ())
+(2258 interfaces #f #f ())
+(2259 set-interface-name! 2258 7 ())
+(2260 interfaces #f #f ())
+(2261 interface-name 2260 7 ())
+(2262 interfaces #f #f ())
+(2263 really-make-interface 2262 7 ())
+(2264 interfaces #f #f ())
+(2265 interfaces #f #f ())
+(2266 interface? 2265 7 ())
+(2267 interfaces #f #f ())
+(2268 interface-ref 2267 7 ())
+(2269 interfaces #f #f ())
+(2270 for-each-declaration 2269 7 ())
+(2271 interfaces #f #f ())
+(2272 note-reference-to-interface! 2271 7 ())
+(2273 interfaces #f #f ())
+(2274 make-interface 2273 7 ())
+(2275 interfaces #f #f ())
+(2276 really-make-simple-interface 2275 7 ())
+(2277 #f 2276 6 ())
+(2278 #f 2276 11 ())
+(2279 interfaces #f #f ())
+(2280 make-simple-interface 2279 7 ())
+(2281 #f 2280 23 ())
+(2282 #f 2281 66 ())
+(2283 interfaces #f #f ())
+(2284 make-compound-interface 2283 7 ())
+(2285 #f 2284 12 ())
+(2286 loop 2285 18 ())
+(2287 #f 2284 17 ())
+(2288 #f 2287 6 ())
+(2289 #f 2284 38 ())
+(2290 interfaces #f #f ())
+(2291 note-interface-name! 2290 7 ())
+(2292 bindings #f #f ())
+(2293 bindings #f #f ())
+(2294 binding-type 2293 7 ())
+(2295 bindings #f #f ())
+(2296 binding-place 2295 7 ())
+(2297 bindings #f #f ())
+(2298 binding-static 2297 7 ())
+(2299 bindings #f #f ())
+(2300 binding-path 2299 7 ())
+(2301 bindings #f #f ())
+(2302 set-binding-place! 2301 7 ())
+(2303 bindings #f #f ())
+(2304 make-binding 2303 7 ())
+(2305 bindings #f #f ())
+(2306 add-path 2305 7 ())
+(2307 bindings #f #f ())
+(2308 clobber-binding! 2307 7 ())
+(2309 bindings #f #f ())
+(2310 impose-type 2309 7 ())
+(2311 bindings #f #f ())
+(2312 forget-integration 2311 7 ())
+(2313 bindings #f #f ())
+(2314 same-denotation? 2313 7 ())
+(2315 bindings #f #f ())
+(2316 follow-forwarding-pointers 2315 7 ())
+(2317 bindings #f #f ())
+(2318 maybe-fix-place! 2317 7 ())
+(2319 names #f #f ())
+(2320 #f 2319 7 ())
+(2321 names #f #f ())
+(2322 transform-procedure 2321 7 ())
+(2323 names #f #f ())
+(2324 transform-env 2323 7 ())
+(2325 names #f #f ())
+(2326 transform-type 2325 7 ())
+(2327 names #f #f ())
+(2328 transform-aux-names 2327 7 ())
+(2329 names #f #f ())
+(2330 transform-source 2329 7 ())
+(2331 names #f #f ())
+(2332 transform-id 2331 7 ())
+(2333 names #f #f ())
+(2334 really-make-transform 2333 7 ())
+(2335 names #f #f ())
+(2336 names #f #f ())
+(2337 names #f #f ())
+(2338 #f 2337 11 ())
+(2339 names #f #f ())
+(2340 generated-symbol 2339 7 ())
+(2341 names #f #f ())
+(2342 generated-token 2341 7 ())
+(2343 names #f #f ())
+(2344 generated-env 2343 7 ())
+(2345 names #f #f ())
+(2346 generated-parent-name 2345 7 ())
+(2347 names #f #f ())
+(2348 make-generated 2347 7 ())
+(2349 names #f #f ())
+(2350 names #f #f ())
+(2351 generated? 2350 7 ())
+(2352 names #f #f ())
+(2353 name? 2352 7 ())
+(2354 names #f #f ())
+(2355 generate-name 2354 7 ())
+(2356 names #f #f ())
+(2357 generated-uid 2356 7 ())
+(2358 names #f #f ())
+(2359 name->symbol 2358 7 ())
+(2360 names #f #f ())
+(2361 name-hash 2360 7 ())
+(2362 names #f #f ())
+(2363 desyntaxify 2362 7 ())
+(2364 loop 2363 267 ())
+(2365 names #f #f ())
+(2366 make-qualified 2365 7 ())
+(2367 names #f #f ())
+(2368 qualified? 2367 7 ())
+(2369 names #f #f ())
+(2370 qualified-parent-name 2369 7 ())
+(2371 names #f #f ())
+(2372 qualified-symbol 2371 7 ())
+(2373 names #f #f ())
+(2374 lookup 2373 7 ())
+(2375 names #f #f ())
+(2376 transform? 2375 7 ())
+(2377 names #f #f ())
+(2378 qualify-parent 2377 7 ())
+(2379 recur 2378 18 ())
+(2380 names #f #f ())
+(2381 name->qualified 2380 7 ())
+(2382 names #f #f ())
+(2383 make-transform 2382 7 ())
+(2384 names #f #f ())
+(2385 name->source-name 2384 7 ())
+(2386 names #f #f ())
+(2387 make-keyword-comparator 2386 7 ())
+(2388 #f 2387 6 ())
+(2389 names #f #f ())
+(2390 make-name-generator 2389 7 ())
+(2391 #f 2390 13 ())
+(2392 names #f #f ())
+(2393 bind-aliases 2392 7 ())
+(2394 #f 2393 36 ())
+(2395 names #f #f ())
+(2396 maybe-apply-macro-transform 2395 7 ())
+(2397 names #f #f ())
+(2398 apply-inline-transform 2397 7 ())
+(2399 names #f #f ())
+(2400 compiler-envs #f #f ())
+(2401 compiler-envs #f #f ())
+(2402 compiler-envs #f #f ())
+(2403 compiler-envs #f #f ())
+(2404 compiler-envs #f #f ())
+(2405 lookup 2404 7 ())
+(2406 compiler-envs #f #f ())
+(2407 bind1 2406 7 ())
+(2408 #f 2407 6 ())
+(2409 compiler-envs #f #f ())
+(2410 bind 2409 7 ())
+(2411 compiler-envs #f #f ())
+(2412 bindrec 2411 7 ())
+(2413 #f 2412 17 ())
+(2414 compiler-envs #f #f ())
+(2415 make-compiler-env 2414 7 ())
+(2416 #f 2415 6 ())
+(2417 compiler-envs #f #f ())
+(2418 environment-macro-eval 2417 7 ())
+(2419 compiler-envs #f #f ())
+(2420 environment-define! 2419 7 ())
+(2421 compiler-envs #f #f ())
+(2422 extract-package-from-environment 2421 7 ())
+(2423 compiler-envs #f #f ())
+(2424 bind-source-file-name 2423 7 ())
+(2425 compiler-envs #f #f ())
+(2426 source-file-name 2425 7 ())
+(2427 thingies #f #f ())
+(2428 thingie-binding 2427 7 ())
+(2429 thingies #f #f ())
+(2430 thingie-name 2429 7 ())
+(2431 thingies #f #f ())
+(2432 thingie-want-type 2431 7 ())
+(2433 thingies #f #f ())
+(2434 make-thingie 2433 7 ())
+(2435 thingies #f #f ())
+(2436 thingies #f #f ())
+(2437 thingie? 2436 7 ())
+(2438 packages #f #f ())
+(2439 #f 2438 11 ())
+(2440 packages #f #f ())
+(2441 packages #f #f ())
+(2442 packages #f #f ())
+(2443 packages #f #f ())
+(2444 packages #f #f ())
+(2445 packages #f #f ())
+(2446 packages #f #f ())
+(2447 packages #f #f ())
+(2448 #f 2447 11 ())
+(2449 packages #f #f ())
+(2450 package-uid 2449 7 ())
+(2451 packages #f #f ())
+(2452 set-package-opens! 2451 7 ())
+(2453 packages #f #f ())
+(2454 package-opens-really 2453 7 ())
+(2455 packages #f #f ())
+(2456 package-definitions 2455 7 ())
+(2457 packages #f #f ())
+(2458 package-unstable? 2457 7 ())
+(2459 packages #f #f ())
+(2460 set-package-integrate?! 2459 7 ())
+(2461 packages #f #f ())
+(2462 package-integrate? 2461 7 ())
+(2463 packages #f #f ())
+(2464 set-package-get-location! 2463 7 ())
+(2465 packages #f #f ())
+(2466 package-get-location 2465 7 ())
+(2467 packages #f #f ())
+(2468 package-file-name 2467 7 ())
+(2469 packages #f #f ())
+(2470 package-clauses 2469 7 ())
+(2471 packages #f #f ())
+(2472 set-package-loaded?! 2471 7 ())
+(2473 packages #f #f ())
+(2474 package-loaded? 2473 7 ())
+(2475 packages #f #f ())
+(2476 set-package->environment! 2475 7 ())
+(2477 packages #f #f ())
+(2478 package->environment 2477 7 ())
+(2479 packages #f #f ())
+(2480 set-package-opens-thunk! 2479 7 ())
+(2481 packages #f #f ())
+(2482 package-opens-thunk 2481 7 ())
+(2483 packages #f #f ())
+(2484 package-accesses-thunk 2483 7 ())
+(2485 packages #f #f ())
+(2486 set-package-undefineds! 2485 7 ())
+(2487 packages #f #f ())
+(2488 package-real-undefineds 2487 7 ())
+(2489 packages #f #f ())
+(2490 set-package-undefined-but-assigneds! 2489 7 ())
+(2491 packages #f #f ())
+(2492 package-real-undefined-but-assigneds 2491 7 ())
+(2493 packages #f #f ())
+(2494 package-clients 2493 7 ())
+(2495 packages #f #f ())
+(2496 package-cached 2495 7 ())
+(2497 packages #f #f ())
+(2498 really-make-package 2497 7 ())
+(2499 packages #f #f ())
+(2500 packages #f #f ())
+(2501 #f 2500 11 ())
+(2502 packages #f #f ())
+(2503 structure-interface-thunk 2502 7 ())
+(2504 packages #f #f ())
+(2505 set-structure-interface! 2504 7 ())
+(2506 packages #f #f ())
+(2507 structure-interface-really 2506 7 ())
+(2508 packages #f #f ())
+(2509 structure-package 2508 7 ())
+(2510 packages #f #f ())
+(2511 structure-clients 2510 7 ())
+(2512 packages #f #f ())
+(2513 set-structure-name! 2512 7 ())
+(2514 packages #f #f ())
+(2515 structure-name 2514 7 ())
+(2516 packages #f #f ())
+(2517 really-make-structure 2516 7 ())
+(2518 packages #f #f ())
+(2519 packages #f #f ())
+(2520 structure? 2519 7 ())
+(2521 packages #f #f ())
+(2522 initialize-structure! 2521 7 ())
+(2523 packages #f #f ())
+(2524 structure-interface 2523 7 ())
+(2525 packages #f #f ())
+(2526 package? 2525 7 ())
+(2527 packages #f #f ())
+(2528 note-package-name! 2527 7 ())
+(2529 packages #f #f ())
+(2530 note-structure-name! 2529 7 ())
+(2531 packages #f #f ())
+(2532 make-structure 2531 7 ())
+(2533 #f 2532 85 ())
+(2534 packages #f #f ())
+(2535 structure-unstable? 2534 7 ())
+(2536 packages #f #f ())
+(2537 get-new-location 2536 7 ())
+(2538 packages #f #f ())
+(2539 package-define! 2538 7 ())
+(2540 packages #f #f ())
+(2541 package-accesses 2540 7 ())
+(2542 packages #f #f ())
+(2543 initialize-package! 2542 7 ())
+(2544 #f 2543 45 ())
+(2545 #f 2543 59 ())
+(2546 packages #f #f ())
+(2547 initialize-package-if-necessary! 2546 7 ())
+(2548 packages #f #f ())
+(2549 package-definition 2548 7 ())
+(2550 packages #f #f ())
+(2551 search-opens 2550 7 ())
+(2552 loop 2551 18 ())
+(2553 packages #f #f ())
+(2554 structure-lookup 2553 7 ())
+(2555 packages #f #f ())
+(2556 package-lookup 2555 7 ())
+(2557 packages #f #f ())
+(2558 generic-lookup 2557 7 ())
+(2559 packages #f #f ())
+(2560 really-package-lookup 2559 7 ())
+(2561 packages #f #f ())
+(2562 real-structure-lookup 2561 7 ())
+(2563 packages #f #f ())
+(2564 for-each-export 2563 7 ())
+(2565 #f 2564 22 ())
+(2566 packages #f #f ())
+(2567 really-package->environment 2566 7 ())
+(2568 #f 2567 6 ())
+(2569 #f 2567 11 ())
+(2570 packages #f #f ())
+(2571 new-package-uid 2570 7 ())
+(2572 packages #f #f ())
+(2573 make-package 2572 7 ())
+(2574 packages #f #f ())
+(2575 lazy-table-accessor 2574 7 ())
+(2576 #f 2575 6 ())
+(2577 packages #f #f ())
+(2578 package-name 2577 7 ())
+(2579 packages #f #f ())
+(2580 package-opens 2579 7 ())
+(2581 packages #f #f ())
+(2582 make-simple-package 2581 7 ())
+(2583 #f 2582 65 ())
+(2584 #f 2582 70 ())
+(2585 packages #f #f ())
+(2586 package-add-static! 2585 7 ())
+(2587 packages #f #f ())
+(2588 package-refine-type! 2587 7 ())
+(2589 packages #f #f ())
+(2590 for-each-definition 2589 7 ())
+(2591 #f 2590 6 ())
+(2592 packages #f #f ())
+(2593 make-new-location 2592 7 ())
+(2594 packages #f #f ())
+(2595 flush-location-names 2594 7 ())
+(2596 packages #f #f ())
+(2597 print-undefined-names 2596 7 ())
+(2598 #f 2597 10 ())
+(2599 #f 2597 184 ())
+(2600 packages #f #f ())
+(2601 noting-undefined-variables 2600 7 ())
+(2602 add-name 2601 13 ())
+(2603 #f 2601 25 ())
+(2604 #f 2601 30 ())
+(2605 #f 2604 3 ())
+(2606 #f 2604 11 ())
+(2607 #f 2606 3 ())
+(2608 packages #f #f ())
+(2609 cenv->package 2608 7 ())
+(2610 packages #f #f ())
+(2611 get-location-for-unassignable 2610 7 ())
+(2612 #f 2611 98 ())
+(2613 #f 2611 103 ())
+(2614 packages #f #f ())
+(2615 package-note-caching! 2614 7 ())
+(2616 loop 2615 79 ())
+(2617 packages #f #f ())
+(2618 note-caching! 2617 7 ())
+(2619 packages #f #f ())
+(2620 location-for-reference 2619 7 ())
+(2621 loop 2620 28 ())
+(2622 packages #f #f ())
+(2623 get-location-for-undefined 2622 7 ())
+(2624 #f 2623 105 ())
+(2625 packages #f #f ())
+(2626 get-location 2625 7 ())
+(2627 packages #f #f ())
+(2628 really-link! 2627 7 ())
+(2629 loop##277 2628 11 ())
+(2630 packages #f #f ())
+(2631 link! 2630 7 ())
+(2632 #f 2631 14 ())
+(2633 packages #f #f ())
+(2634 location-on-demand 2633 7 ())
+(2635 #f 2634 6 ())
+(2636 packages #f #f ())
+(2637 packages #f #f ())
+(2638 environments #f #f ())
+(2639 set-reflective-tower-maker! 2638 28 ())
+(2640 environments #f #f ())
+(2641 make-reflective-tower 2640 7 ())
+(2642 recur 2641 19 ())
+(2643 #f 2642 6 ())
+(2644 environments #f #f ())
+(2645 null-environment 2644 7 ())
+(2646 environments #f #f ())
+(2647 set-scheme-report-environment! 2646 7 ())
+(2648 environments #f #f ())
+(2649 environments #f #f ())
+(2650 environments #f #f ())
+(2651 environments #f #f ())
+(2652 scheme-report-environment 2651 7 ())
+(2653 environments #f #f ())
+(2654 with-interaction-environment 2653 7 ())
+(2655 environments #f #f ())
+(2656 set-interaction-environment! 2655 7 ())
+(2657 environments #f #f ())
+(2658 interaction-environment 2657 7 ())
+(2659 environments #f #f ())
+(2660 environments #f #f ())
+(2661 carefully 2660 7 ())
+(2662 environments #f #f ())
+(2663 *structure-ref 2662 7 ())
+(2664 environments #f #f ())
+(2665 environment-define! 2664 7 ())
+(2666 environments #f #f ())
+(2667 environment-set! 2666 7 ())
+(2668 #f 2667 115 ())
+(2669 environments #f #f ())
+(2670 environment-ref 2669 7 ())
+(2671 #f 2670 22 ())
+(2672 filenames #f #f ())
+(2673 translate 2672 7 ())
+(2674 loop 2673 26 ())
+(2675 filenames #f #f ())
+(2676 set-translation! 2675 7 ())
+(2677 filenames #f #f ())
+(2678 translations 2677 7 ())
+(2679 filenames #f #f ())
+(2680 filenames #f #f ())
+(2681 string-posq 2680 7 ())
+(2682 loop 2681 19 ())
+(2683 filenames #f #f ())
+(2684 file-nondirectory-position 2683 7 ())
+(2685 loop 2684 24 ())
+(2686 filenames #f #f ())
+(2687 file-name-nondirectory 2686 7 ())
+(2688 filenames #f #f ())
+(2689 file-name-directory 2688 7 ())
+(2690 filenames #f #f ())
+(2691 filenames #f #f ())
+(2692 filenames #f #f ())
+(2693 filenames #f #f ())
+(2694 namestring-component 2693 7 ())
+(2695 filenames #f #f ())
+(2696 filenames #f #f ())
+(2697 filenames #f #f ())
+(2698 namestring 2697 7 ())
+(2699 #f 2698 192 ())
+(2700 reading-forms #f #f ())
+(2701 really-read-forms 2700 7 ())
+(2702 loop 2701 19 ())
+(2703 reading-forms #f #f ())
+(2704 read-forms 2703 7 ())
+(2705 #f 2704 47 ())
+(2706 reading-forms #f #f ())
+(2707 #f 2706 11 ())
+(2708 nodes #f #f ())
+(2709 #f 2708 15 ())
+(2710 nodes #f #f ())
+(2711 #f 2710 19 ())
+(2712 nodes #f #f ())
+(2713 #f 2712 19 ())
+(2714 #f 2713 29 ())
+(2715 #f 2713 57 ())
+(2716 nodes #f #f ())
+(2717 nodes #f #f ())
+(2718 nodes #f #f ())
+(2719 #f 2718 19 ())
+(2720 #f 2719 6 ())
+(2721 nodes #f #f ())
+(2722 #f 2721 19 ())
+(2723 nodes #f #f ())
+(2724 #f 2723 19 ())
+(2725 nodes #f #f ())
+(2726 #f 2725 11 ())
+(2727 nodes #f #f ())
+(2728 #f 2727 11 ())
+(2729 nodes #f #f ())
+(2730 node-operator-id 2729 7 ())
+(2731 nodes #f #f ())
+(2732 node-form 2731 7 ())
+(2733 nodes #f #f ())
+(2734 set-node-plist! 2733 7 ())
+(2735 nodes #f #f ())
+(2736 node-plist 2735 7 ())
+(2737 nodes #f #f ())
+(2738 really-make-node 2737 7 ())
+(2739 nodes #f #f ())
+(2740 nodes #f #f ())
+(2741 nodes #f #f ())
+(2742 nodes #f #f ())
+(2743 nodes #f #f ())
+(2744 nodes #f #f ())
+(2745 #f 2744 11 ())
+(2746 nodes #f #f ())
+(2747 set-operator-type! 2746 7 ())
+(2748 nodes #f #f ())
+(2749 operator-type 2748 7 ())
+(2750 nodes #f #f ())
+(2751 operator-nargs 2750 7 ())
+(2752 nodes #f #f ())
+(2753 operator-uid 2752 7 ())
+(2754 nodes #f #f ())
+(2755 operator-name 2754 7 ())
+(2756 nodes #f #f ())
+(2757 make-operator 2756 7 ())
+(2758 nodes #f #f ())
+(2759 nodes #f #f ())
+(2760 operator? 2759 7 ())
+(2761 nodes #f #f ())
+(2762 get-operator 2761 7 ())
+(2763 nodes #f #f ())
+(2764 make-operator-table 2763 7 ())
+(2765 nodes #f #f ())
+(2766 operator-lookup 2765 7 ())
+(2767 nodes #f #f ())
+(2768 operator-define! 2767 7 ())
+(2769 nodes #f #f ())
+(2770 node? 2769 7 ())
+(2771 nodes #f #f ())
+(2772 make-node 2771 7 ())
+(2773 nodes #f #f ())
+(2774 node-ref 2773 7 ())
+(2775 nodes #f #f ())
+(2776 node-set! 2775 7 ())
+(2777 loop 2776 103 ())
+(2778 nodes #f #f ())
+(2779 node-operator 2778 7 ())
+(2780 nodes #f #f ())
+(2781 node-predicate 2780 7 ())
+(2782 #f 2781 37 ())
+(2783 nodes #f #f ())
+(2784 make-similar-node 2783 7 ())
+(2785 nodes #f #f ())
+(2786 force-node 2785 7 ())
+(2787 nodes #f #f ())
+(2788 schemify-node 2787 7 ())
+(2789 nodes #f #f ())
+(2790 schemify-sexp 2789 7 ())
+(2791 loop 2790 147 ())
+(2792 nodes #f #f ())
+(2793 schemify 2792 7 ())
+(2794 nodes #f #f ())
+(2795 schemify-nodes 2794 7 ())
+(2796 #f 2795 6 ())
+(2797 nodes #f #f ())
+(2798 define-schemifier 2797 7 ())
+(2799 nodes #f #f ())
+(2800 schemify-formals 2799 7 ())
+(2801 nodes #f #f ())
+(2802 schemify-lambda 2801 7 ())
+(2803 nodes #f #f ())
+(2804 nodes #f #f ())
+(2805 var-utilities #f #f ())
+(2806 normalize-formals 2805 7 ())
+(2807 var-utilities #f #f ())
+(2808 n-ary? 2807 7 ())
+(2809 var-utilities #f #f ())
+(2810 number-of-required-args 2809 7 ())
+(2811 loop##296 2810 11 ())
+(2812 syntactic #f #f ())
+(2813 syntactic #f #f ())
+(2814 syntactic #f #f ())
+(2815 syntactic #f #f ())
+(2816 syntactic #f #f ())
+(2817 syntactic #f #f ())
+(2818 syntactic #f #f ())
+(2819 syntactic #f #f ())
+(2820 syntactic #f #f ())
+(2821 syntactic #f #f ())
+(2822 syntactic #f #f ())
+(2823 syntactic #f #f ())
+(2824 syntactic #f #f ())
+(2825 syntactic #f #f ())
+(2826 syntactic #f #f ())
+(2827 syntactic #f #f ())
+(2828 syntactic #f #f ())
+(2829 #f 2828 19 ())
+(2830 #f 2829 113 ())
+(2831 syntactic #f #f ())
+(2832 #f 2831 19 ())
+(2833 #f 2832 104 ())
+(2834 #f 2833 6 ())
+(2835 syntactic #f #f ())
+(2836 #f 2835 19 ())
+(2837 #f 2836 108 ())
+(2838 syntactic #f #f ())
+(2839 #f 2838 19 ())
+(2840 syntactic #f #f ())
+(2841 #f 2840 19 ())
+(2842 #f 2841 87 ())
+(2843 syntactic #f #f ())
+(2844 #f 2843 19 ())
+(2845 syntactic #f #f ())
+(2846 #f 2845 19 ())
+(2847 syntactic #f #f ())
+(2848 #f 2847 19 ())
+(2849 syntactic #f #f ())
+(2850 #f 2849 19 ())
+(2851 syntactic #f #f ())
+(2852 #f 2851 19 ())
+(2853 syntactic #f #f ())
+(2854 #f 2853 19 ())
+(2855 syntactic #f #f ())
+(2856 #f 2855 19 ())
+(2857 syntactic #f #f ())
+(2858 #f 2857 19 ())
+(2859 syntactic #f #f ())
+(2860 #f 2859 11 ())
+(2861 syntactic #f #f ())
+(2862 syntactic #f #f ())
+(2863 syntactic #f #f ())
+(2864 syntactic #f #f ())
+(2865 at-least-this-long? 2864 7 ())
+(2866 syntactic #f #f ())
+(2867 names? 2866 7 ())
+(2868 syntactic #f #f ())
+(2869 destructure-define 2868 7 ())
+(2870 syntactic #f #f ())
+(2871 scan-define 2870 7 ())
+(2872 syntactic #f #f ())
+(2873 this-long? 2872 7 ())
+(2874 syntactic #f #f ())
+(2875 process-syntax 2874 7 ())
+(2876 syntactic #f #f ())
+(2877 scan-define-syntax 2876 7 ())
+(2878 syntactic #f #f ())
+(2879 expand-name 2878 7 ())
+(2880 syntactic #f #f ())
+(2881 expand-operator-form 2880 7 ())
+(2882 syntactic #f #f ())
+(2883 literal? 2882 7 ())
+(2884 syntactic #f #f ())
+(2885 expand-literal 2884 7 ())
+(2886 syntactic #f #f ())
+(2887 expand-list 2886 7 ())
+(2888 #f 2887 6 ())
+(2889 syntactic #f #f ())
+(2890 expand-call 2889 7 ())
+(2891 syntactic #f #f ())
+(2892 expand 2891 7 ())
+(2893 syntactic #f #f ())
+(2894 expand-macro-application 2893 7 ())
+(2895 #f 2894 6 ())
+(2896 syntactic #f #f ())
+(2897 expand-structure-ref 2896 7 ())
+(2898 lose 2897 32 ())
+(2899 syntactic #f #f ())
+(2900 expand-head 2899 7 ())
+(2901 syntactic #f #f ())
+(2902 scan-forms 2901 7 ())
+(2903 loop 2902 22 ())
+(2904 syntactic #f #f ())
+(2905 expand-define 2904 7 ())
+(2906 syntactic #f #f ())
+(2907 expand-scanned-form 2906 7 ())
+(2908 syntactic #f #f ())
+(2909 expand-form 2908 7 ())
+(2910 loop 2909 32 ())
+(2911 syntactic #f #f ())
+(2912 static-value 2911 7 ())
+(2913 syntactic #f #f ())
+(2914 make-operator-predicate 2913 7 ())
+(2915 #f 2914 26 ())
+(2916 syntactic #f #f ())
+(2917 body-lossage 2916 7 ())
+(2918 syntactic #f #f ())
+(2919 scan-body-forms 2918 7 ())
+(2920 #f 2919 231 ())
+(2921 syntactic #f #f ())
+(2922 expand-letrec 2921 7 ())
+(2923 #f 2922 10 ())
+(2924 syntactic #f #f ())
+(2925 expand-body 2924 7 ())
+(2926 #f 2925 33 ())
+(2927 syntactic #f #f ())
+(2928 define-expander 2927 7 ())
+(2929 syntactic #f #f ())
+(2930 unspecific-node 2929 7 ())
+(2931 syntactic #f #f ())
+(2932 bind-names 2931 7 ())
+(2933 loop 2932 26 ())
+(2934 syntactic #f #f ())
+(2935 expand-lambda 2934 7 ())
+(2936 #f 2935 6 ())
+(2937 syntactic #f #f ())
+(2938 specs? 2937 7 ())
+(2939 syntactic #f #f ())
+(2940 syntax? 2939 7 ())
+(2941 primops #f #f ())
+(2942 primops #f #f ())
+(2943 #f 2942 11 ())
+(2944 primops #f #f ())
+(2945 primop-name 2944 7 ())
+(2946 primops #f #f ())
+(2947 primop-type 2946 7 ())
+(2948 primops #f #f ())
+(2949 primop-closed 2948 7 ())
+(2950 primops #f #f ())
+(2951 primop-compilator 2950 7 ())
+(2952 primops #f #f ())
+(2953 make-primop 2952 7 ())
+(2954 primops #f #f ())
+(2955 primops #f #f ())
+(2956 primop? 2955 7 ())
+(2957 primops #f #f ())
+(2958 walk-primops 2957 7 ())
+(2959 #f 2958 6 ())
+(2960 primops #f #f ())
+(2961 define-compiler-primitive 2960 7 ())
+(2962 primops #f #f ())
+(2963 get-primop 2962 7 ())
+(2964 debug-data #f #f ())
+(2965 #f 2964 7 ())
+(2966 debug-data #f #f ())
+(2967 debug-data-uid 2966 7 ())
+(2968 debug-data #f #f ())
+(2969 debug-data-name 2968 7 ())
+(2970 debug-data #f #f ())
+(2971 debug-data-parent 2970 7 ())
+(2972 debug-data #f #f ())
+(2973 debug-data-pc-in-parent 2972 7 ())
+(2974 debug-data #f #f ())
+(2975 set-debug-data-env-maps! 2974 7 ())
+(2976 debug-data #f #f ())
+(2977 debug-data-env-maps 2976 7 ())
+(2978 debug-data #f #f ())
+(2979 set-debug-data-source! 2978 7 ())
+(2980 debug-data #f #f ())
+(2981 debug-data-source 2980 7 ())
+(2982 debug-data #f #f ())
+(2983 make-debug-data 2982 7 ())
+(2984 debug-data #f #f ())
+(2985 debug-data #f #f ())
+(2986 debug-data? 2985 7 ())
+(2987 stack-check #f #f ())
+(2988 loop##324 2987 8 ())
+(2989 stack-check #f #f ())
+(2990 #f 2989 11 ())
+(2991 loop 2990 48 ())
+(2992 stack-check #f #f ())
+(2993 #f 2992 11 ())
+(2994 stack-check #f #f ())
+(2995 #f 2994 11 ())
+(2996 stack-check #f #f ())
+(2997 stack-check #f #f ())
+(2998 stack-check #f #f ())
+(2999 #f 2998 11 ())
+(3000 loop 2999 68 ())
+(3001 stack-check #f #f ())
+(3002 #f 3001 11 ())
+(3003 stack-check #f #f ())
+(3004 #f 3003 11 ())
+(3005 stack-check #f #f ())
+(3006 #f 3005 11 ())
+(3007 stack-check #f #f ())
+(3008 #f 3007 11 ())
+(3009 stack-check #f #f ())
+(3010 stack-check #f #f ())
+(3011 stack-check #f #f ())
+(3012 stack-check #f #f ())
+(3013 stack-check #f #f ())
+(3014 stack-check #f #f ())
+(3015 stack-check #f #f ())
+(3016 stack-check #f #f ())
+(3017 stack-check #f #f ())
+(3018 stack-check #f #f ())
+(3019 stack-check #f #f ())
+(3020 stack-check #f #f ())
+(3021 stack-check #f #f ())
+(3022 stack-check #f #f ())
+(3023 stack-check #f #f ())
+(3024 stack-check #f #f ())
+(3025 stack-check #f #f ())
+(3026 stack-max 3025 7 ())
+(3027 stack-check #f #f ())
+(3028 protocol-skip 3027 7 ())
+(3029 stack-check #f #f ())
+(3030 maximum-stack-use 3029 7 ())
+(3031 loop##327 3030 74 ())
+(3032 stack-check #f #f ())
+(3033 nothing 3032 7 ())
+(3034 #f 3033 6 ())
+(3035 stack-check #f #f ())
+(3036 popper 3035 7 ())
+(3037 #f 3036 6 ())
+(3038 stack-check #f #f ())
+(3039 imax 3038 7 ())
+(3040 stack-check #f #f ())
+(3041 pusher 3040 7 ())
+(3042 #f 3041 6 ())
+(3043 stack-check #f #f ())
+(3044 continue 3043 7 ())
+(3045 stack-check #f #f ())
+(3046 continuer 3045 7 ())
+(3047 #f 3046 6 ())
+(3048 stack-check #f #f ())
+(3049 get-offset 3048 7 ())
+(3050 stack-check #f #f ())
+(3051 do-make-cont 3050 7 ())
+(3052 #f 3051 6 ())
+(3053 stack-check #f #f ())
+(3054 arg-spec-size 3053 7 ())
+(3055 stack-check #f #f ())
+(3056 stack-function 3055 7 ())
+(3057 loop 3056 22 ())
+(3058 segments #f #f ())
+(3059 segments #f #f ())
+(3060 segments #f #f ())
+(3061 segments #f #f ())
+(3062 #f 3061 15 ())
+(3063 segments #f #f ())
+(3064 astate-code-vector 3063 7 ())
+(3065 segments #f #f ())
+(3066 set-astate-pc! 3065 7 ())
+(3067 segments #f #f ())
+(3068 astate-pc 3067 7 ())
+(3069 segments #f #f ())
+(3070 set-astate-count! 3069 7 ())
+(3071 segments #f #f ())
+(3072 astate-count 3071 7 ())
+(3073 segments #f #f ())
+(3074 set-astate-literals! 3073 7 ())
+(3075 segments #f #f ())
+(3076 astate-literals 3075 7 ())
+(3077 segments #f #f ())
+(3078 make-assembly-state 3077 7 ())
+(3079 segments #f #f ())
+(3080 segments #f #f ())
+(3081 segments #f #f ())
+(3082 segments #f #f ())
+(3083 segments #f #f ())
+(3084 segments #f #f ())
+(3085 segments #f #f ())
+(3086 segments #f #f ())
+(3087 segments #f #f ())
+(3088 segments #f #f ())
+(3089 segments #f #f ())
+(3090 segments #f #f ())
+(3091 segments #f #f ())
+(3092 segments #f #f ())
+(3093 new-template-uid 3092 7 ())
+(3094 segments #f #f ())
+(3095 template-uid 3094 7 ())
+(3096 segments #f #f ())
+(3097 set-template-uid! 3096 7 ())
+(3098 segments #f #f ())
+(3099 debug-flag-accessor 3098 7 ())
+(3100 #f 3099 26 ())
+(3101 segments #f #f ())
+(3102 debug-flag-modifier 3101 7 ())
+(3103 #f 3102 26 ())
+(3104 segments #f #f ())
+(3105 saving-and-restoring 3104 7 ())
+(3106 swap 3105 6 ())
+(3107 segments #f #f ())
+(3108 with-fresh-compiler-state 3107 7 ())
+(3109 #f 3108 44 ())
+(3110 #f 3109 3 ())
+(3111 #f 3109 8 ())
+(3112 segments #f #f ())
+(3113 note-debug-data! 3112 7 ())
+(3114 segments #f #f ())
+(3115 debug-data->info 3114 7 ())
+(3116 segments #f #f ())
+(3117 get-debug-data 3116 7 ())
+(3118 segments #f #f ())
+(3119 new-debug-data 3118 7 ())
+(3120 segments #f #f ())
+(3121 high-byte 3120 7 ())
+(3122 segments #f #f ())
+(3123 emit-byte! 3122 7 ())
+(3124 segments #f #f ())
+(3125 low-byte 3124 7 ())
+(3126 segments #f #f ())
+(3127 position 3126 7 ())
+(3128 loop 3127 22 ())
+(3129 segments #f #f ())
+(3130 literal-position 3129 7 ())
+(3131 #f 3130 21 ())
+(3132 segments #f #f ())
+(3133 literal->index 3132 7 ())
+(3134 segments #f #f ())
+(3135 emit-literal! 3134 7 ())
+(3136 segments #f #f ())
+(3137 code-vector-set2! 3136 7 ())
+(3138 segments #f #f ())
+(3139 check-stack-use 3138 7 ())
+(3140 loop##338 3139 77 ())
+(3141 segments #f #f ())
+(3142 emit-segment! 3141 7 ())
+(3143 segments #f #f ())
+(3144 emit-with-environment-maps! 3143 7 ())
+(3145 #f 3144 14 ())
+(3146 segments #f #f ())
+(3147 make-astate 3146 7 ())
+(3148 segments #f #f ())
+(3149 template 3148 7 ())
+(3150 #f 3149 10 ())
+(3151 segments #f #f ())
+(3152 segment-data->template 3151 7 ())
+(3153 loop##340 3152 68 ())
+(3154 segments #f #f ())
+(3155 segment->template 3154 7 ())
+(3156 #f 3155 124 ())
+(3157 segments #f #f ())
+(3158 instruction 3157 7 ())
+(3159 #f 3158 30 ())
+(3160 #f 3159 22 ())
+(3161 segments #f #f ())
+(3162 sequentially-2 3161 7 ())
+(3163 #f 3162 59 ())
+(3164 segments #f #f ())
+(3165 sequentially 3164 7 ())
+(3166 loop 3165 105 ())
+(3167 #f 3165 120 ())
+(3168 loop 3167 18 ())
+(3169 segments #f #f ())
+(3170 instruction-with-literal 3169 7 ())
+(3171 #f 3170 30 ())
+(3172 #f 3171 160 ())
+(3173 segments #f #f ())
+(3174 instruction-with-location 3173 7 ())
+(3175 #f 3174 10 ())
+(3176 segments #f #f ())
+(3177 make-label 3176 7 ())
+(3178 segments #f #f ())
+(3179 insert-label! 3178 7 ())
+(3180 segments #f #f ())
+(3181 instruction-using-label 3180 7 ())
+(3182 #f 3181 49 ())
+(3183 segments #f #f ())
+(3184 computed-goto-instruction 3183 7 ())
+(3185 #f 3184 68 ())
+(3186 loop##341 3185 75 ())
+(3187 segments #f #f ())
+(3188 attach-label 3187 7 ())
+(3189 #f 3188 19 ())
+(3190 #f 3189 37 ())
+(3191 segments #f #f ())
+(3192 note-source-code 3191 7 ())
+(3193 #f 3192 19 ())
+(3194 segments #f #f ())
+(3195 note-environment 3194 7 ())
+(3196 #f 3195 31 ())
+(3197 segments #f #f ())
+(3198 segments #f #f ())
+(3199 segments #f #f ())
+(3200 reconstruction #f #f ())
+(3201 constant-type 3200 7 ())
+(3202 reconstruction #f #f ())
+(3203 reconstruction #f #f ())
+(3204 reconstruction #f #f ())
+(3205 reconstruct-apply 3204 7 ())
+(3206 #f 3205 56 ())
+(3207 reconstruction #f #f ())
+(3208 #f 3207 11 ())
+(3209 reconstruction #f #f ())
+(3210 #f 3209 11 ())
+(3211 #f 3210 10 ())
+(3212 reconstruction #f #f ())
+(3213 #f 3212 15 ())
+(3214 reconstruction #f #f ())
+(3215 define-primop-reconstructor 3214 7 ())
+(3216 reconstruction #f #f ())
+(3217 reconstruction #f #f ())
+(3218 reconstruction #f #f ())
+(3219 reconstruction #f #f ())
+(3220 reconstruction #f #f ())
+(3221 #f 3220 15 ())
+(3222 reconstruction #f #f ())
+(3223 #f 3222 15 ())
+(3224 reconstruction #f #f ())
+(3225 node->type 3224 7 ())
+(3226 reconstruction #f #f ())
+(3227 #f 3226 15 ())
+(3228 reconstruction #f #f ())
+(3229 #f 3228 15 ())
+(3230 #f 3229 60 ())
+(3231 reconstruction #f #f ())
+(3232 #f 3231 15 ())
+(3233 reconstruction #f #f ())
+(3234 #f 3233 15 ())
+(3235 loop##343 3234 11 ())
+(3236 reconstruction #f #f ())
+(3237 reconstruction #f #f ())
+(3238 fork-constraints 3237 7 ())
+(3239 #f 3238 13 ())
+(3240 reconstruction #f #f ())
+(3241 #f 3240 15 ())
+(3242 #f 3241 153 ())
+(3243 reconstruction #f #f ())
+(3244 #f 3243 13 ())
+(3245 reconstruction #f #f ())
+(3246 #f 3245 13 ())
+(3247 reconstruction #f #f ())
+(3248 #f 3247 15 ())
+(3249 reconstruction #f #f ())
+(3250 #f 3249 15 ())
+(3251 reconstruction #f #f ())
+(3252 reconstruct-call 3251 7 ())
+(3253 lose 3252 112 ())
+(3254 #f 3253 3 ())
+(3255 loop 3252 179 ())
+(3256 reconstruction #f #f ())
+(3257 proc->reconstructor 3256 7 ())
+(3258 reconstruction #f #f ())
+(3259 #f 3258 15 ())
+(3260 reconstruction #f #f ())
+(3261 reconstruct-name 3260 7 ())
+(3262 reconstruction #f #f ())
+(3263 #f 3262 15 ())
+(3264 reconstruction #f #f ())
+(3265 careful-codomain 3264 7 ())
+(3266 reconstruction #f #f ())
+(3267 reconstruct-lambda 3266 7 ())
+(3268 #f 3267 71 ())
+(3269 reconstruction #f #f ())
+(3270 #f 3269 15 ())
+(3271 reconstruction #f #f ())
+(3272 #f 3271 15 ())
+(3273 reconstruction #f #f ())
+(3274 define-reconstructor 3273 7 ())
+(3275 reconstruction #f #f ())
+(3276 #f 3275 11 ())
+(3277 reconstruction #f #f ())
+(3278 examine 3277 7 ())
+(3279 reconstruction #f #f ())
+(3280 reconstruct 3279 7 ())
+(3281 reconstruction #f #f ())
+(3282 reconstruct-type 3281 7 ())
+(3283 reconstruction #f #f ())
+(3284 node-type 3283 7 ())
+(3285 compiler #f #f ())
+(3286 compiler #f #f ())
+(3287 loop 3286 60 ())
+(3288 compiler #f #f ())
+(3289 compiler #f #f ())
+(3290 compiler #f #f ())
+(3291 define-one-or-two 3290 7 ())
+(3292 #f 3291 12 ())
+(3293 #f 3291 17 ())
+(3294 compiler #f #f ())
+(3295 define-one-or-two 3294 7 ())
+(3296 #f 3295 73 ())
+(3297 #f 3295 78 ())
+(3298 compiler #f #f ())
+(3299 compiler #f #f ())
+(3300 compiler #f #f ())
+(3301 define=< 3300 7 ())
+(3302 #f 3301 73 ())
+(3303 #f 3301 78 ())
+(3304 compiler #f #f ())
+(3305 define+* 3304 7 ())
+(3306 #f 3305 43 ())
+(3307 #f 3305 48 ())
+(3308 compiler #f #f ())
+(3309 define-char-io 3308 7 ())
+(3310 #f 3309 12 ())
+(3311 #f 3309 17 ())
+(3312 compiler #f #f ())
+(3313 define-char-io 3312 7 ())
+(3314 #f 3313 12 ())
+(3315 #f 3313 17 ())
+(3316 compiler #f #f ())
+(3317 n-ary-constructor 3316 7 ())
+(3318 #f 3317 16 ())
+(3319 #f 3317 21 ())
+(3320 compiler #f #f ())
+(3321 #f 3320 21 ())
+(3322 compiler #f #f ())
+(3323 #f 3322 44 ())
+(3324 #f 3323 112 ())
+(3325 #f 3322 49 ())
+(3326 compiler #f #f ())
+(3327 #f 3326 17 ())
+(3328 #f 3326 22 ())
+(3329 compiler #f #f ())
+(3330 #f 3329 73 ())
+(3331 #f 3329 84 ())
+(3332 compiler #f #f ())
+(3333 #f 3332 71 ())
+(3334 #f 3332 76 ())
+(3335 compiler #f #f ())
+(3336 #f 3335 57 ())
+(3337 #f 3335 62 ())
+(3338 compiler #f #f ())
+(3339 compiler #f #f ())
+(3340 #f 3339 7 ())
+(3341 compiler #f #f ())
+(3342 compiler #f #f ())
+(3343 #f 3342 7 ())
+(3344 compiler #f #f ())
+(3345 compiler #f #f ())
+(3346 compiler #f #f ())
+(3347 compiler #f #f ())
+(3348 compiler #f #f ())
+(3349 loop##347 3348 12 ())
+(3350 compiler #f #f ())
+(3351 compiler #f #f ())
+(3352 #f 3351 19 ())
+(3353 compiler #f #f ())
+(3354 compiler #f #f ())
+(3355 compiler #f #f ())
+(3356 compiler #f #f ())
+(3357 compiler #f #f ())
+(3358 compiler #f #f ())
+(3359 compiler #f #f ())
+(3360 compiler #f #f ())
+(3361 #f 3360 19 ())
+(3362 compiler #f #f ())
+(3363 compiler #f #f ())
+(3364 compiler #f #f ())
+(3365 compiler #f #f ())
+(3366 compiler #f #f ())
+(3367 #f 3366 19 ())
+(3368 #f 3367 73 ())
+(3369 #f 3367 157 ())
+(3370 compiler #f #f ())
+(3371 #f 3370 19 ())
+(3372 compiler #f #f ())
+(3373 #f 3372 19 ())
+(3374 compiler #f #f ())
+(3375 compiler #f #f ())
+(3376 #f 3375 19 ())
+(3377 loop 3376 89 ())
+(3378 compiler #f #f ())
+(3379 #f 3378 19 ())
+(3380 compiler #f #f ())
+(3381 #f 3380 19 ())
+(3382 compiler #f #f ())
+(3383 #f 3382 19 ())
+(3384 compiler #f #f ())
+(3385 #f 3384 19 ())
+(3386 compiler #f #f ())
+(3387 #f 3386 41 ())
+(3388 compiler #f #f ())
+(3389 #f 3388 41 ())
+(3390 compiler #f #f ())
+(3391 #f 3390 19 ())
+(3392 compiler #f #f ())
+(3393 #f 3392 11 ())
+(3394 compiler #f #f ())
+(3395 diagnose-call-error 3394 7 ())
+(3396 #f 3395 173 ())
+(3397 compiler #f #f ())
+(3398 type-check 3397 7 ())
+(3399 #f 3398 121 ())
+(3400 compiler #f #f ())
+(3401 compile 3400 7 ())
+(3402 compiler #f #f ())
+(3403 compile-expression 3402 7 ())
+(3404 compiler #f #f ())
+(3405 define-compilator 3404 7 ())
+(3406 compiler #f #f ())
+(3407 ignore-values-cont? 3406 7 ())
+(3408 compiler #f #f ())
+(3409 deliver-value 3408 7 ())
+(3410 compiler #f #f ())
+(3411 compile-constant 3410 7 ())
+(3412 compiler #f #f ())
+(3413 return-cont? 3412 7 ())
+(3414 compiler #f #f ())
+(3415 fixup-source 3414 7 ())
+(3416 compiler #f #f ())
+(3417 maybe-push-continuation 3416 7 ())
+(3418 compiler #f #f ())
+(3419 make-cont 3418 7 ())
+(3420 compiler #f #f ())
+(3421 fall-through-cont 3420 7 ())
+(3422 compiler #f #f ())
+(3423 push-arguments 3422 7 ())
+(3424 recur 3423 37 ())
+(3425 compiler #f #f ())
+(3426 compile-unknown-call 3425 7 ())
+(3427 compiler #f #f ())
+(3428 name-node-binding 3427 7 ())
+(3429 compiler #f #f ())
+(3430 compile-name-call 3429 7 ())
+(3431 compiler #f #f ())
+(3432 generate-trap 3431 7 ())
+(3433 compiler #f #f ())
+(3434 named-cont 3433 7 ())
+(3435 compiler #f #f ())
+(3436 push-all-with-names 3435 7 ())
+(3437 compiler #f #f ())
+(3438 set-lexical-offsets! 3437 7 ())
+(3439 loop 3438 22 ())
+(3440 compiler #f #f ())
+(3441 name-node->symbol 3440 7 ())
+(3442 compiler #f #f ())
+(3443 return-cont 3442 7 ())
+(3444 compiler #f #f ())
+(3445 compile-lambda-code 3444 7 ())
+(3446 compiler #f #f ())
+(3447 cont-name 3446 7 ())
+(3448 compiler #f #f ())
+(3449 compile-redex 3448 7 ())
+(3450 compiler #f #f ())
+(3451 compile-call 3450 7 ())
+(3452 compiler #f #f ())
+(3453 compile-lambda 3452 7 ())
+(3454 compiler #f #f ())
+(3455 variable-env-data 3454 7 ())
+(3456 level-loop 3455 26 ())
+(3457 loop 3456 60 ())
+(3458 loop 3457 123 ())
+(3459 compiler #f #f ())
+(3460 sort-list 3459 7 ())
+(3461 insert 3460 11 ())
+(3462 sort 3460 32 ())
+(3463 compiler #f #f ())
+(3464 get-variables-offsets 3463 7 ())
+(3465 loop 3464 22 ())
+(3466 compiler #f #f ())
+(3467 compile-flat-lambda 3466 7 ())
+(3468 #f 3467 26 ())
+(3469 #f 3467 366 ())
+(3470 compiler #f #f ())
+(3471 fall-through-cont? 3470 7 ())
+(3472 compiler #f #f ())
+(3473 ignore-values-cont 3472 7 ())
+(3474 compiler #f #f ())
+(3475 set-type-check?! 3474 7 ())
+(3476 compiler #f #f ())
+(3477 push-all-but-last 3476 7 ())
+(3478 recur 3477 25 ())
+(3479 compiler #f #f ())
+(3480 direct-compilator 3479 7 ())
+(3481 #f 3480 6 ())
+(3482 compiler #f #f ())
+(3483 direct-closed-compilator 3482 7 ())
+(3484 #f 3483 6 ())
+(3485 compiler #f #f ())
+(3486 nargs->domain 3485 7 ())
+(3487 loop##356 3486 11 ())
+(3488 compiler #f #f ())
+(3489 get-primop-type 3488 7 ())
+(3490 #f 3489 10 ())
+(3491 compiler #f #f ())
+(3492 simple-compilator 3491 7 ())
+(3493 #f 3492 6 ())
+(3494 compiler #f #f ())
+(3495 simple-closed-compilator 3494 7 ())
+(3496 #f 3495 6 ())
+(3497 compiler #f #f ())
+(3498 define-simple-primitive 3497 7 ())
+(3499 compiler #f #f ())
+(3500 symbol-append 3499 7 ())
+(3501 compiler #f #f ())
+(3502 define-stob-predicate 3501 7 ())
+(3503 compiler #f #f ())
+(3504 define-data-struct-primitives 3503 7 ())
+(3505 def-prim 3504 8 ())
+(3506 loop##358 3504 190 ())
+(3507 compiler #f #f ())
+(3508 define-vector-primitives 3507 7 ())
+(3509 def-prim 3508 26 ())
+(3510 compiler #f #f ())
+(3511 n-ary-primitive-compilator 3510 7 ())
+(3512 #f 3511 6 ())
+(3513 compiler #f #f ())
+(3514 define-n-ary-compiler-primitive 3513 7 ())
+(3515 compiler #f #f ())
+(3516 call-on-arg-and-id 3515 7 ())
+(3517 compiler #f #f ())
+(3518 call-on-args 3517 7 ())
+(3519 do-arg 3518 6 ())
+(3520 loop 3518 52 ())
+(3521 compiler #f #f ())
+(3522 make-dispatch-protocol 3521 7 ())
+(3523 compiler #f #f ())
+(3524 compile-definition 3523 7 ())
+(3525 compiler #f #f ())
+(3526 compile-form 3525 7 ())
+(3527 compiler #f #f ())
+(3528 compile-forms-loop 3527 7 ())
+(3529 compiler #f #f ())
+(3530 compile-forms 3529 7 ())
+(3531 compiler #f #f ())
+(3532 append-templates 3531 7 ())
+(3533 #f 3532 31 ())
+(3534 compiler #f #f ())
+(3535 make-startup-procedure 3534 7 ())
+(3536 compiler #f #f ())
+(3537 evaluation #f #f ())
+(3538 compile-and-run 3537 7 ())
+(3539 #f 3538 61 ())
+(3540 #f 3539 6 ())
+(3541 evaluation #f #f ())
+(3542 really-load-into 3541 7 ())
+(3543 evaluation #f #f ())
+(3544 load 3543 7 ())
+(3545 evaluation #f #f ())
+(3546 eval-from-file 3545 7 ())
+(3547 evaluation #f #f ())
+(3548 load-into 3547 7 ())
+(3549 evaluation #f #f ())
+(3550 eval 3549 7 ())
+(3551 scheme #f #f ())
+(3552 display-conditions #f #f ())
+(3553 limited-write 3552 7 ())
+(3554 recur 3553 22 ())
+(3555 #f 3554 145 ())
+(3556 #f 3555 24 ())
+(3557 display-conditions #f #f ())
+(3558 &disclose-condition 3557 52 ())
+(3559 display-conditions #f #f ())
+(3560 display-conditions #f #f ())
+(3561 display-conditions #f #f ())
+(3562 display-conditions #f #f ())
+(3563 display-conditions #f #f ())
+(3564 really-display-condition 3563 7 ())
+(3565 #f 3564 246 ())
+(3566 display-conditions #f #f ())
+(3567 display-condition 3566 22 ())
+(3568 #f 3567 10 ())
+(3569 mini-command #f #f ())
+(3570 read-string 3569 7 ())
+(3571 loop 3570 23 ())
+(3572 mini-command #f #f ())
+(3573 mini-load 3572 7 ())
+(3574 mini-command #f #f ())
+(3575 command-processor 3574 7 ())
+(3576 loop 3575 77 ())
+(3577 #f 3576 7 ())
+(3578 #f 3577 6 ())
+(3579 #f 3578 68 ())
+(3580 #f 3577 11 ())
+(3581 #f 3580 75 ())
+(3582 #f 3580 201 ())
+(3583 #f 3580 246 ())
+(3584 #f 3583 12 ())
+(3585 export-the-record-type #f #f ())
+(3586 enum-case #f #f ())
+(3587 scheduler #f #f ())
+(3588 decrement-counter! 3587 7 ())
+(3589 scheduler #f #f ())
+(3590 increment-counter! 3589 7 ())
+(3591 scheduler #f #f ())
+(3592 scheduler #f #f ())
+(3593 make-counter 3592 7 ())
+(3594 scheduler #f #f ())
+(3595 round-robin-event-handler 3594 7 ())
+(3596 thread-event-handler 3595 15 ())
+(3597 #f 3596 111 ())
+(3598 asynchronous-event-handler 3595 24 ())
+(3599 next-thread 3595 33 ())
+(3600 #f 3599 18 ())
+(3601 scheduler #f #f ())
+(3602 run-threads-with-housekeeper 3601 7 ())
+(3603 #f 3602 6 ())
+(3604 loop 3603 29 ())
+(3605 #f 3604 6 ())
+(3606 #f 3605 57 ())
+(3607 scheduler #f #f ())
+(3608 run-threads 3607 7 ())
+(3609 #f 3608 6 ())
+(3610 loop 3609 26 ())
+(3611 #f 3610 6 ())
+(3612 #f 3611 8 ())
+(3613 root-scheduler #f #f ())
+(3614 root-scheduler #f #f ())
+(3615 spawn-output-forcers 3614 7 ())
+(3616 root-scheduler #f #f ())
+(3617 call-when-deadlocked! 3616 7 ())
+(3618 root-scheduler #f #f ())
+(3619 root-scheduler #f #f ())
+(3620 do-some-waiting 3619 7 ())
+(3621 root-scheduler #f #f ())
+(3622 root-scheduler #f #f ())
+(3623 root-wait 3622 7 ())
+(3624 #f 3623 22 ())
+(3625 root-scheduler #f #f ())
+(3626 scheme-exit-now 3625 7 ())
+(3627 root-scheduler #f #f ())
+(3628 root-scheduler #f #f ())
+(3629 cheap-display-condition 3628 7 ())
+(3630 #f 3629 164 ())
+(3631 root-scheduler #f #f ())
+(3632 root-handler 3631 7 ())
+(3633 root-scheduler #f #f ())
+(3634 make-root-event-handler 3633 7 ())
+(3635 #f 3634 115 ())
+(3636 #f 3634 120 ())
+(3637 root-scheduler #f #f ())
+(3638 root-scheduler 3637 7 ())
+(3639 #f 3638 13 ())
+(3640 #f 3639 24 ())
+(3641 #f 3639 41 ())
+(3642 usual-resumer #f #f ())
+(3643 usual-resumer #f #f ())
+(3644 initialize-rts 3643 7 ())
+(3645 #f 3644 44 ())
+(3646 #f 3645 7 ())
+(3647 #f 3646 46 ())
+(3648 #f 3647 3 ())
+(3649 usual-resumer #f #f ())
+(3650 usual-resumer 3649 7 ())
+(3651 #f 3650 6 ())
+(3652 #f 3651 15 ())
+(3653 initial-system #f #f ())
+(3654 make-tower 3653 7 ())
+(3655 initial-system #f #f ())
+(3656 make-initial-package 3655 7 ())
+(3657 #f 3656 17 ())
+(3658 initial-system #f #f ())
+(3659 initialize-interaction-environment! 3658 7 ())
+(3660 initial-system #f #f ())
+(3661 make-built-in-structures 3660 7 ())
+(3662 #f 3661 38 ())
+(3663 #f 3661 60 ())
+(3664 initial-system #f #f ())
+(3665 start 3664 7 ())
+(3666 #f 3665 6 ())
+(3667 #f 3666 6 ())
+(3668 #f 3667 64 ())
+(3669 usual-macros #f #f ())
+(3670 find-free-names-in-syntax-rules 3669 7 ())
+(3671 meta-variables 3670 13 ())
+(3672 free-names 3670 22 ())
+(3673 loop##378 3670 36 ())
+(3674 usual-macros #f #f ())
+(3675 usual-macros #f #f ())
+(3676 segment-tail 3675 7 ())
+(3677 loop 3676 21 ())
+(3678 usual-macros #f #f ())
+(3679 segment-depth 3678 7 ())
+(3680 usual-macros #f #f ())
+(3681 segment-template? 3680 7 ())
+(3682 usual-macros #f #f ())
+(3683 segment-pattern? 3682 7 ())
+(3684 usual-macros #f #f ())
+(3685 process-rules 3684 7 ())
+(3686 make-transformer 3685 424 ())
+(3687 process-rule 3685 433 ())
+(3688 #f 3687 114 ())
+(3689 process-match 3685 442 ())
+(3690 process-segment-match 3685 451 ())
+(3691 process-pattern 3685 460 ())
+(3692 #f 3691 97 ())
+(3693 process-template 3685 469 ())
+(3694 loop##382 3693 294 ())
+(3695 meta-variables 3685 478 ())
+(3696 free-meta-variables 3685 487 ())
+(3697 usual-macros #f #f ())
+(3698 #f 3697 11 ())
+(3699 usual-macros #f #f ())
+(3700 #f 3699 11 ())
+(3701 expand-quasiquote 3700 154 ())
+(3702 finalize-quasiquote 3700 163 ())
+(3703 descend-quasiquote 3700 172 ())
+(3704 descend-quasiquote-pair 3700 181 ())
+(3705 #f 3704 15 ())
+(3706 #f 3705 15 ())
+(3707 descend-quasiquote-vector 3700 190 ())
+(3708 #f 3707 22 ())
+(3709 interesting-to-quasiquote? 3700 199 ())
+(3710 usual-macros #f #f ())
+(3711 case-clause? 3710 7 ())
+(3712 usual-macros #f #f ())
+(3713 #f 3712 11 ())
+(3714 #f 3713 28 ())
+(3715 #f 3713 218 ())
+(3716 usual-macros #f #f ())
+(3717 #f 3716 11 ())
+(3718 usual-macros #f #f ())
+(3719 specs? 3718 7 ())
+(3720 usual-macros #f #f ())
+(3721 #f 3720 11 ())
+(3722 usual-macros #f #f ())
+(3723 #f 3722 11 ())
+(3724 usual-macros #f #f ())
+(3725 do-spec? 3724 7 ())
+(3726 usual-macros #f #f ())
+(3727 #f 3726 11 ())
+(3728 #f 3727 238 ())
+(3729 usual-macros #f #f ())
+(3730 #f 3729 11 ())
+(3731 recur 3730 85 ())
+(3732 usual-macros #f #f ())
+(3733 #f 3732 11 ())
+(3734 usual-macros #f #f ())
+(3735 usual-transform 3734 7 ())
+(3736 usual-macros #f #f ())
+(3737 define-usual-macro 3736 7 ())
+(3738 usual-macros #f #f ())
+(3739 strong #f #f ())
+(3740 pop-vertex-edge! 3739 7 ())
+(3741 strong #f #f ())
+(3742 follow-edge 3741 7 ())
+(3743 strong #f #f ())
+(3744 unwind-stack 3743 7 ())
+(3745 loop 3744 22 ())
+(3746 strong #f #f ())
+(3747 end-vertex 3746 7 ())
+(3748 #f 3747 6 ())
+(3749 strong #f #f ())
+(3750 get-strong 3749 7 ())
+(3751 strong #f #f ())
+(3752 do-vertex 3751 7 ())
+(3753 strong #f #f ())
+(3754 make-vertices 3753 7 ())
+(3755 maybe-slot 3754 6 ())
+(3756 #f 3754 18 ())
+(3757 #f 3754 36 ())
+(3758 strong #f #f ())
+(3759 make-vertex 3758 7 ())
+(3760 strong #f #f ())
+(3761 vertex? 3760 7 ())
+(3762 strong #f #f ())
+(3763 vertex-data 3762 7 ())
+(3764 strong #f #f ())
+(3765 set-vertex-edges! 3764 7 ())
+(3766 strong #f #f ())
+(3767 vertex-edges 3766 7 ())
+(3768 strong #f #f ())
+(3769 set-vertex-stack! 3768 7 ())
+(3770 strong #f #f ())
+(3771 vertex-stack 3770 7 ())
+(3772 strong #f #f ())
+(3773 set-vertex-index! 3772 7 ())
+(3774 strong #f #f ())
+(3775 vertex-index 3774 7 ())
+(3776 strong #f #f ())
+(3777 set-vertex-parent! 3776 7 ())
+(3778 strong #f #f ())
+(3779 vertex-parent 3778 7 ())
+(3780 strong #f #f ())
+(3781 set-vertex-lowpoint! 3780 7 ())
+(3782 strong #f #f ())
+(3783 vertex-lowpoint 3782 7 ())
+(3784 strong #f #f ())
+(3785 really-make-vertex 3784 7 ())
+(3786 strong #f #f ())
+(3787 strong #f #f ())
+(3788 find-next-vertex 3787 7 ())
+(3789 loop##404 3788 11 ())
+(3790 strong #f #f ())
+(3791 strongly-connected-components 3790 7 ())
+(3792 loop 3791 52 ())
+(3793 #f 3792 39 ())
+(3794 #f 3792 57 ())
+(3795 usages #f #f ())
+(3796 insert-aliases 3795 7 ())
+(3797 loop 3796 22 ())
+(3798 usages #f #f ())
+(3799 make-form 3798 7 ())
+(3800 usages #f #f ())
+(3801 #f 3800 11 ())
+(3802 usages #f #f ())
+(3803 form? 3802 7 ())
+(3804 usages #f #f ())
+(3805 form-node 3804 7 ())
+(3806 usages #f #f ())
+(3807 set-form-aliases! 3806 7 ())
+(3808 usages #f #f ())
+(3809 form-aliases 3808 7 ())
+(3810 usages #f #f ())
+(3811 set-form-unaliased?! 3810 7 ())
+(3812 usages #f #f ())
+(3813 form-unaliased? 3812 7 ())
+(3814 usages #f #f ())
+(3815 set-form-free! 3814 7 ())
+(3816 usages #f #f ())
+(3817 form-free 3816 7 ())
+(3818 usages #f #f ())
+(3819 set-form-temp! 3818 7 ())
+(3820 usages #f #f ())
+(3821 form-temp 3820 7 ())
+(3822 usages #f #f ())
+(3823 really-make-form 3822 7 ())
+(3824 usages #f #f ())
+(3825 usages #f #f ())
+(3826 topologically-sort 3825 7 ())
+(3827 #f 3826 13 ())
+(3828 #f 3827 6 ())
+(3829 #f 3827 15 ())
+(3830 usages #f #f ())
+(3831 maybe-make-aliased 3830 7 ())
+(3832 usages #f #f ())
+(3833 stuff-count 3832 7 ())
+(3834 #f 3833 10 ())
+(3835 usages #f #f ())
+(3836 sort-forms 3835 7 ())
+(3837 #f 3836 39 ())
+(3838 #f 3836 71 ())
+(3839 usages #f #f ())
+(3840 usages #f #f ())
+(3841 usages #f #f ())
+(3842 usages #f #f ())
+(3843 usages #f #f ())
+(3844 usages #f #f ())
+(3845 usages #f #f ())
+(3846 usages #f #f ())
+(3847 usages #f #f ())
+(3848 usages #f #f ())
+(3849 usage-incrementator 3848 7 ())
+(3850 #f 3849 6 ())
+(3851 usages #f #f ())
+(3852 package-usage? 3851 7 ())
+(3853 usages #f #f ())
+(3854 make-package-usage 3853 7 ())
+(3855 usages #f #f ())
+(3856 make-usage 3855 7 ())
+(3857 usages #f #f ())
+(3858 usage? 3857 7 ())
+(3859 usages #f #f ())
+(3860 usage-name-node 3859 7 ())
+(3861 usages #f #f ())
+(3862 set-reference! 3861 7 ())
+(3863 usages #f #f ())
+(3864 usage-reference-count 3863 7 ())
+(3865 usages #f #f ())
+(3866 set-operator! 3865 7 ())
+(3867 usages #f #f ())
+(3868 usage-operator-count 3867 7 ())
+(3869 usages #f #f ())
+(3870 set-assignment! 3869 7 ())
+(3871 usages #f #f ())
+(3872 usage-assignment-count 3871 7 ())
+(3873 usages #f #f ())
+(3874 really-make-usage 3873 7 ())
+(3875 usages #f #f ())
+(3876 usages #f #f ())
+(3877 #f 3876 15 ())
+(3878 usages #f #f ())
+(3879 #f 3878 15 ())
+(3880 usages #f #f ())
+(3881 #f 3880 15 ())
+(3882 usages #f #f ())
+(3883 #f 3882 15 ())
+(3884 usages #f #f ())
+(3885 #f 3884 15 ())
+(3886 usages #f #f ())
+(3887 #f 3886 15 ())
+(3888 usages #f #f ())
+(3889 #f 3888 15 ())
+(3890 #f 3889 57 ())
+(3891 usages #f #f ())
+(3892 #f 3891 15 ())
+(3893 #f 3892 41 ())
+(3894 usages #f #f ())
+(3895 #f 3894 13 ())
+(3896 usages #f #f ())
+(3897 add-if-free 3896 7 ())
+(3898 usages #f #f ())
+(3899 #f 3898 13 ())
+(3900 usages #f #f ())
+(3901 usages #f #f ())
+(3902 usages #f #f ())
+(3903 usages #f #f ())
+(3904 usages #f #f ())
+(3905 usages #f #f ())
+(3906 nothing 3905 7 ())
+(3907 usages #f #f ())
+(3908 define-usage-analyzer 3907 7 ())
+(3909 usages #f #f ())
+(3910 #f 3909 11 ())
+(3911 usages #f #f ())
+(3912 analyze-nodes 3911 7 ())
+(3913 #f 3912 6 ())
+(3914 usages #f #f ())
+(3915 analyze 3914 7 ())
+(3916 usages #f #f ())
+(3917 find-node-usages 3916 7 ())
+(3918 #f 3917 30 ())
+(3919 #f 3917 44 ())
+(3920 usages #f #f ())
+(3921 maybe-update-known-type 3920 7 ())
+(3922 usages #f #f ())
+(3923 find-usages 3922 7 ())
+(3924 #f 3923 23 ())
+(3925 #f 3923 41 ())
+(3926 #f 3925 24 ())
+(3927 #f 3923 59 ())
+(3928 inline #f #f ())
+(3929 inline #f #f ())
+(3930 inline #f #f ())
+(3931 inline #f #f ())
+(3932 inline #f #f ())
+(3933 inline #f #f ())
+(3934 get-qualified-env 3933 7 ())
+(3935 inline #f #f ())
+(3936 qualified->name 3935 7 ())
+(3937 recur 3936 18 ())
+(3938 inline #f #f ())
+(3939 inline #f #f ())
+(3940 inline #f #f ())
+(3941 reconstitute-name 3940 7 ())
+(3942 inline #f #f ())
+(3943 reconstitute 3942 7 ())
+(3944 label 3943 18 ())
+(3945 inline #f #f ())
+(3946 make-substitution 3945 7 ())
+(3947 #f 3946 29 ())
+(3948 inline #f #f ())
+(3949 inline-transform 3948 7 ())
+(3950 #f 3949 63 ())
+(3951 #f 3949 71 ())
+(3952 inline #f #f ())
+(3953 unused-name 3952 7 ())
+(3954 loop##428 3953 46 ())
+(3955 #f 3954 10 ())
+(3956 inline #f #f ())
+(3957 clean-lookup 3956 7 ())
+(3958 inline #f #f ())
+(3959 clean-lambda 3958 7 ())
+(3960 #f 3959 41 ())
+(3961 recur 3959 91 ())
+(3962 inline #f #f ())
+(3963 clean-node 3962 7 ())
+(3964 #f 3963 132 ())
+(3965 #f 3963 296 ())
+(3966 inline #f #f ())
+(3967 make-inline-transform 3966 7 ())
+(3968 #f 3967 41 ())
+(3969 #f 3967 96 ())
+(3970 loop##429 3969 11 ())
+(3971 for-reification #f #f ())
+(3972 package-define-static! 3971 7 ())
+(3973 for-reification #f #f ())
+(3974 transform 3973 7 ())
+(3975 for-reification #f #f ())
+(3976 package 3975 7 ())
+(3977 loop##430 3976 73 ())
+(3978 for-reification #f #f ())
+(3979 simple-interface 3978 7 ())
+(3980 #f 3979 12 ())
+(3981 for-reification #f #f ())
+(3982 primop 3981 7 ())
+(3983 for-reification #f #f ())
+(3984 operator 3983 7 ())
+(3985 types #f #f ())
+(3986 types #f #f ())
+(3987 types #f #f ())
+(3988 types #f #f ())
+(3989 types #f #f ())
+(3990 types #f #f ())
+(3991 types #f #f ())
+(3992 types #f #f ())
+(3993 types #f #f ())
+(3994 types #f #f ())
+(3995 types #f #f ())
+(3996 types #f #f ())
+(3997 types #f #f ())
+(3998 types #f #f ())
+(3999 types #f #f ())
+(4000 types #f #f ())
+(4001 types #f #f ())
+(4002 types #f #f ())
+(4003 types #f #f ())
+(4004 types #f #f ())
+(4005 types #f #f ())
+(4006 types #f #f ())
+(4007 procedure 4006 7 ())
+(4008 types #f #f ())
+(4009 types #f #f ())
+(4010 types #f #f ())
+(4011 types #f #f ())
+(4012 defpackage #f #f ())
+(4013 note-name! 4012 7 ())
+(4014 defpackage #f #f ())
+(4015 set-verify-later! 4014 7 ())
+(4016 defpackage #f #f ())
+(4017 verify-later! 4016 7 ())
+(4018 defpackage #f #f ())
+(4019 *verify-later!* 4018 7 ())
+(4020 defpackage #f #f ())
+(4021 defpackage #f #f ())
+(4022 loser 4021 7 ())
+(4023 defpackage #f #f ())
+(4024 make-a-package 4023 7 ())
+(4025 optimizer #f #f ())
+(4026 apply-optimizers 4025 7 ())
+(4027 #f 4026 6 ())
+(4028 optimizer #f #f ())
+(4029 get-optimizer 4028 7 ())
+(4030 #f 4029 6 ())
+(4031 #f 4030 10 ())
+(4032 #f 4031 55 ())
+(4033 optimizer #f #f ())
+(4034 set-optimizer! 4033 7 ())
+(4035 optimizer #f #f ())
+(4036 scan-package #f #f ())
+(4037 check-structure 4036 7 ())
+(4038 #f 4037 17 ())
+(4039 scan-package #f #f ())
+(4040 package-optimizer-names 4039 7 ())
+(4041 #f 4040 36 ())
+(4042 #f 4040 75 ())
+(4043 scan-package #f #f ())
+(4044 read-files 4043 7 ())
+(4045 #f 4044 30 ())
+(4046 scan-package #f #f ())
+(4047 package-source 4046 7 ())
+(4048 #f 4047 46 ())
+(4049 scan-package #f #f ())
+(4050 collect-packages 4049 7 ())
+(4051 recur 4050 26 ())
+(4052 #f 4051 150 ())
+(4053 compile-packages #f #f ())
+(4054 compile-packages #f #f ())
+(4055 compile-packages #f #f ())
+(4056 make-define-primitive-node 4055 7 ())
+(4057 compile-packages #f #f ())
+(4058 define-primitives 4057 7 ())
+(4059 #f 4058 17 ())
+(4060 #f 4058 36 ())
+(4061 compile-packages #f #f ())
+(4062 define-usual-transform 4061 7 ())
+(4063 compile-packages #f #f ())
+(4064 expand-package 4063 7 ())
+(4065 #f 4064 21 ())
+(4066 #f 4065 10 ())
+(4067 #f 4065 28 ())
+(4068 #f 4065 82 ())
+(4069 #f 4068 15 ())
+(4070 #f 4069 10 ())
+(4071 compile-packages #f #f ())
+(4072 compile-package 4071 7 ())
+(4073 module-system #f #f ())
+(4074 analysis #f #f ())
+(4075 analysis #f #f ())
+(4076 analysis #f #f ())
+(4077 analysis #f #f ())
+(4078 analysis #f #f ())
+(4079 package-lookup-type 4078 7 ())
+(4080 analysis #f #f ())
+(4081 analysis #f #f ())
+(4082 require 4081 7 ())
+(4083 analysis #f #f ())
+(4084 simple-literal? 4083 7 ())
+(4085 analysis #f #f ())
+(4086 analysis #f #f ())
+(4087 analysis #f #f ())
+(4088 lexical-node? 4087 7 ())
+(4089 analysis #f #f ())
+(4090 really-simple-call? 4089 7 ())
+(4091 analysis #f #f ())
+(4092 static-value 4091 7 ())
+(4093 analysis #f #f ())
+(4094 #f 4093 11 ())
+(4095 analysis #f #f ())
+(4096 #f 4095 11 ())
+(4097 loop 4096 21 ())
+(4098 analysis #f #f ())
+(4099 #f 4098 11 ())
+(4100 analysis #f #f ())
+(4101 #f 4100 11 ())
+(4102 analysis #f #f ())
+(4103 #f 4102 11 ())
+(4104 analysis #f #f ())
+(4105 #f 4104 11 ())
+(4106 analysis #f #f ())
+(4107 #f 4106 11 ())
+(4108 analysis #f #f ())
+(4109 #f 4108 11 ())
+(4110 analysis #f #f ())
+(4111 #f 4110 11 ())
+(4112 analysis #f #f ())
+(4113 #f 4112 11 ())
+(4114 analysis #f #f ())
+(4115 #f 4114 11 ())
+(4116 analysis #f #f ())
+(4117 #f 4116 11 ())
+(4118 analysis #f #f ())
+(4119 define-analyzer 4118 7 ())
+(4120 analysis #f #f ())
+(4121 #f 4120 11 ())
+(4122 analysis #f #f ())
+(4123 simple-list? 4122 7 ())
+(4124 analysis #f #f ())
+(4125 simple? 4124 7 ())
+(4126 analysis #f #f ())
+(4127 analysis #f #f ())
+(4128 simple-lambda? 4127 7 ())
+(4129 #f 4128 128 ())
+(4130 analysis #f #f ())
+(4131 inlinable-rhs? 4130 7 ())
+(4132 analysis #f #f ())
+(4133 analyze-form 4132 7 ())
+(4134 analysis #f #f ())
+(4135 analyze-forms 4134 7 ())
+(4136 #f 4135 17 ())
+(4137 analysis #f #f ())
+(4138 #f 4137 11 ())
+(4139 flat-environments #f #f ())
+(4140 set-difference 4139 7 ())
+(4141 recur 4140 18 ())
+(4142 flat-environments #f #f ())
+(4143 union 4142 7 ())
+(4144 recur 4143 31 ())
+(4145 flat-environments #f #f ())
+(4146 cell-set!-primop 4145 7 ())
+(4147 flat-environments #f #f ())
+(4148 flat-environments #f #f ())
+(4149 cell-ref-primop 4148 7 ())
+(4150 flat-environments #f #f ())
+(4151 flat-environments #f #f ())
+(4152 make-cell-primop 4151 7 ())
+(4153 flat-environments #f #f ())
+(4154 flat-environments #f #f ())
+(4155 flat-environments #f #f ())
+(4156 flat-environments #f #f ())
+(4157 flat-environments #f #f ())
+(4158 flat-environments #f #f ())
+(4159 flat-environments #f #f ())
+(4160 flat-environments #f #f ())
+(4161 flat-environments #f #f ())
+(4162 flat-environments #f #f ())
+(4163 flat-environments #f #f ())
+(4164 make-primop-call 4163 7 ())
+(4165 flat-environments #f #f ())
+(4166 make-cell-set! 4165 7 ())
+(4167 flat-environments #f #f ())
+(4168 make-cell-ref 4167 7 ())
+(4169 flat-environments #f #f ())
+(4170 make-unassigned-cell 4169 7 ())
+(4171 flat-environments #f #f ())
+(4172 make-cell 4171 7 ())
+(4173 flat-environments #f #f ())
+(4174 #f 4173 11 ())
+(4175 #f 4174 25 ())
+(4176 flat-environments #f #f ())
+(4177 #f 4176 11 ())
+(4178 flat-environments #f #f ())
+(4179 #f 4178 11 ())
+(4180 flat-environments #f #f ())
+(4181 #f 4180 11 ())
+(4182 flat-environments #f #f ())
+(4183 #f 4182 11 ())
+(4184 flat-environments #f #f ())
+(4185 flat-environments #f #f ())
+(4186 flat-environments #f #f ())
+(4187 flat-environments #f #f ())
+(4188 flat-environments #f #f ())
+(4189 flat-environments #f #f ())
+(4190 no-sets 4189 7 ())
+(4191 flat-environments #f #f ())
+(4192 define-set-marker 4191 7 ())
+(4193 flat-environments #f #f ())
+(4194 #f 4193 11 ())
+(4195 flat-environments #f #f ())
+(4196 mark-set-variables! 4195 7 ())
+(4197 flat-environments #f #f ())
+(4198 assigned? 4197 7 ())
+(4199 flat-environments #f #f ())
+(4200 #f 4199 11 ())
+(4201 flat-environments #f #f ())
+(4202 #f 4201 11 ())
+(4203 #f 4202 85 ())
+(4204 #f 4202 99 ())
+(4205 #f 4204 119 ())
+(4206 flat-environments #f #f ())
+(4207 #f 4206 11 ())
+(4208 #f 4207 21 ())
+(4209 flat-environments #f #f ())
+(4210 #f 4209 11 ())
+(4211 #f 4210 21 ())
+(4212 #f 4211 6 ())
+(4213 flat-environments #f #f ())
+(4214 #f 4213 11 ())
+(4215 #f 4214 37 ())
+(4216 flat-environments #f #f ())
+(4217 #f 4216 11 ())
+(4218 flat-environments #f #f ())
+(4219 add-cells 4218 7 ())
+(4220 loop##443 4219 11 ())
+(4221 flat-environments #f #f ())
+(4222 convert-lambda-body 4221 7 ())
+(4223 #f 4222 47 ())
+(4224 flat-environments #f #f ())
+(4225 flatten-lambda 4224 7 ())
+(4226 #f 4225 21 ())
+(4227 flat-environments #f #f ())
+(4228 #f 4227 11 ())
+(4229 flat-environments #f #f ())
+(4230 flat-environments #f #f ())
+(4231 flat-environments #f #f ())
+(4232 flat-environments #f #f ())
+(4233 flat-environments #f #f ())
+(4234 no-free-vars 4233 7 ())
+(4235 flat-environments #f #f ())
+(4236 flatten-list 4235 7 ())
+(4237 loop 4236 26 ())
+(4238 #f 4237 39 ())
+(4239 flat-environments #f #f ())
+(4240 define-flattener 4239 7 ())
+(4241 flat-environments #f #f ())
+(4242 #f 4241 11 ())
+(4243 #f 4242 6 ())
+(4244 flat-environments #f #f ())
+(4245 flatten-node 4244 7 ())
+(4246 flat-environments #f #f ())
+(4247 flatten-form 4246 7 ())
+(4248 #f 4247 73 ())
+(4249 #f 4247 120 ())
+(4250 flat-environments #f #f ())
+(4251 #f 4250 11 ())
+(4252 #f 4251 6 ())
+(4253 ensures-loaded #f #f ())
+(4254 ensure-loaded 4253 7 ())
+(4255 #f 4254 49 ())
+(4256 #f 4255 56 ())
+(4257 #f 4254 61 ())
+(4258 #f #f #f ())
+(4259 #f 4258 3 ())
+(4260 get-location 4259 3 ())
+(4261 #f 4259 10490 ())
+(4262 #f 4259 10539 ())
+(4263 #f 4259 10652 ())
+(4264 #f 4259 10770 ())
+(4265 #f 4259 10851 ())
+(4266 conc 4265 42 ())
+(4267 #f 4266 16 ())
+(4268 #f 4259 12161 ())
+(4269 loop 4268 115 ())
+(4270 #f 4268 202 ())
+(4271 #f 4268 233 ())
+(4272 #f 4268 413 ())
+(4273 #f 4268 471 ())
+(4274 #f 4259 12549 ())
+(4275 mem? 4274 197 ())
+(4276 every? 4274 206 ())
+(4277 #f 4274 219 ())
+(4278 #f 4274 282 ())
+(4279 #f 4259 12745 ())
+(4280 loop##448 4279 66 ())
+(4281 #f 4259 12794 ())
+(4282 #f 4259 14536 ())
+(4283 #f 4259 21629 ())
+(4284 #f 4283 456 ())
+(4285 #f 4259 22563 ())
+(4286 loop 4285 95 ())
+(4287 #f 4259 22720 ())
+(4288 loop 4287 95 ())
+(4289 #f 4259 22845 ())
+(4290 loop 4289 95 ())
+(4291 #f 4259 22938 ())
+(4292 loop 4291 95 ())
+(4293 #f 4259 23031 ())
+(4294 loop 4293 95 ())
+(4295 #f 4259 23124 ())
+(4296 loop 4295 95 ())
+(4297 #f 4259 23217 ())
+(4298 loop 4297 95 ())
+(4299 #f 4259 23310 ())
+(4300 loop 4299 95 ())
+(4301 #f 4259 23403 ())
+(4302 loop 4301 95 ())
+(4303 #f 4259 24099 ())
+(4304 loop 4303 95 ())
+(4305 #f 4259 26351 ())
+(4306 #f 4259 26514 ())
+(4307 #f 4259 26563 ())
+(4308 #f 4259 26612 ())
+(4309 #f 4259 26757 ())
+(4310 #f 4259 26975 ())
+(4311 #f 4259 29898 ())
+(4312 #f 4259 30098 ())
+(4313 #f 4259 30147 ())
+(4314 #f 4259 30196 ())
+(4315 #f 4314 146 ())
+(4316 #f 4259 30245 ())
+(4317 #f 4316 329 ())
+(4318 #f 4316 403 ())
+(4319 #f 4259 30624 ())
+(4320 #f 4259 30673 ())
+(4321 #f 4320 176 ())
+(4322 parse-package-clauses 4259 30731 ())
+(4323 loop 4322 76 ())
+(4324 #f 4259 30740 ())
+(4325 #f 4324 35 ())
+(4326 #f 4325 146 ())
+(4327 #f 4259 30996 ())
+(4328 #f 4259 31045 ())
+(4329 loop 4328 35 ())
+(4330 #f 4259 31158 ())
+(4331 #f 4259 31239 ())
+(4332 #f 4259 31320 ())
+(4333 loop 4332 51 ())
+(4334 #f 4332 90 ())
+(4335 #f 4332 114 ())
+(4336 #f 4259 31401 ())
+(4337 #f 4259 32658 ())
+(4338 #f 4259 32794 ())
+(4339 #f #f #f ())
+-
diff --git a/build/initial.image b/build/initial.image
new file mode 100644
index 0000000..4d5a55f
Binary files /dev/null and b/build/initial.image differ
diff --git a/build/initial.scm b/build/initial.scm
new file mode 100644
index 0000000..db9b7f5
--- /dev/null
+++ b/build/initial.scm
@@ -0,0 +1,58 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Link script.
+
+(define (link-initial-system)
+  (let ((structures-to-open		;Structures to open for the initial
+	 (struct-list scheme		;system's read-eval-print loop.
+		      environments
+		      module-system
+		      ensures-loaded
+		      packages
+		      packages-internal)))  ; package-for-syntax
+    (link-reified-system (append (desirable-structures)
+				 structures-to-open)
+			 '(build initial)
+			 ;; The expression that evaluates to the
+			 ;; procedure that maps the reified-structure alist
+			 ;; to the startup procedure:
+			 `(start ',(map car structures-to-open))
+			 ;; Structures to open for evaluating that
+			 ;; expression and the expression that
+			 ;; evaluates to the reified-structure alist:
+			 initial-system
+			 for-reification
+			 ;; scheme-level-1
+			 )))
+
+(define (desirable-structures)
+  (let ((env (interaction-environment))
+	(l '()))
+    (for-each (lambda (int)
+		(for-each-declaration
+		     (lambda (name type)
+		       (if (not (assq name l))
+			   (let ((s (eval name env)))
+			     (if (structure? s)
+				 (set! l (cons (cons name s) l))))))
+		     int))
+	      (list low-structures-interface
+		    run-time-structures-interface
+		    features-structures-interface
+		    run-time-internals-structures-interface
+		    compiler-structures-interface
+		    initial-structures-interface))
+    (reverse l)))
+
+
+; Your choice of evaluators:
+
+(define scheme (make-scheme environments evaluation))
+; (define scheme (make-scheme mini-environments mini-eval))
+; (define scheme (make-scheme environments run))
+; etc.
+
+; Your choice of command processors.
+
+(define initial-system
+  (make-initial-system scheme (make-mini-command scheme)))
diff --git a/build/load-linker.exec b/build/load-linker.exec
new file mode 100644
index 0000000..953ea60
--- /dev/null
+++ b/build/load-linker.exec
@@ -0,0 +1,90 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Load the linker.    -*- Mode: Scheme; -*-
+
+; Run this script with  ,exec ,load l.exec.
+; After the script is loaded, you can, in principle, do whatever
+; you might do in the usual linker image.  For example, you might do
+; (this is from the Makefile)
+;
+;         ,in link-config
+;         (load-configuration "interfaces.scm") 
+;         (load-configuration "packages.scm") 
+;         (flatload initial-structures) 
+;         (load "initial.scm")  
+;         (link-initial-system)
+;
+; This is intended to be used to debug new versions of the compiler or
+; static linker.
+
+(config '(run (define :arguments :values)))  ;temporary hack
+
+(translate "=scheme48/" "./")
+
+(load-package 'flatloading)
+(open 'flatloading)
+
+(define (r x) (config `(run ,x)))
+
+(r '(define-structure source-file-names (export (%file-name% :syntax))
+      (open scheme-level-1
+	    syntactic
+	    fluids)
+      (begin (define-syntax %file-name%
+	       (syntax-rules ()
+		 ((%file-name%) (fluid $source-file-name)))))))
+
+(r '(define-structure enumerated enumerated-interface
+      (open scheme-level-1 signals)
+      (files (rts defenum scm))))
+
+(r '(define-structure architecture architecture-interface
+      (open scheme-level-1 signals enumerated)
+      (files (rts arch))))
+
+(config '(structure reflective-tower-maker
+		    (export-reflective-tower-maker)))
+
+; Make the new linker obtain its table, record, etc. structures from
+; the currently running Scheme.
+
+(config '(load "packages.scm"))
+(config '(structure %run-time-structures run-time-structures-interface))
+(config '(structure %features-structures features-structures-interface))
+
+(r
+ '(define-structure %linker-structures
+    (make-linker-structures %run-time-structures
+			    %features-structures
+			    (make-compiler-structures %run-time-structures
+						      %features-structures))))
+
+; Load the linker's interface and structure definitions.
+(config '(load "interfaces.scm" "more-interfaces.scm"))
+(let ((z (config '(run %linker-structures)))
+      (env (config interaction-environment)))
+  (config (lambda () (flatload z env))))
+
+; Load the linker.
+(load-package 'link-config)
+
+; Initialize
+(in 'link-config
+    '(open scheme packages packages-internal
+	   reflective-tower-maker))
+
+(in 'linker '(run (set! *debug-linker?* #t)))
+(in 'link-config '(open flatloading))    ; A different one.
+
+; ,open debuginfo packages-internal compiler scan syntactic meta-types
+
+; (in 'link-config '(dump "l.image"))
+
+; ,exec (usual-stuff)
+
+(define (usual-stuff)
+  (in 'link-config)
+  (run '(begin (load-configuration "interfaces.scm")
+	       (load-configuration "packages.scm")
+	       (flatload initial-structures)))
+  (load "initial.scm"))
diff --git a/build/lucid-script.lisp b/build/lucid-script.lisp
new file mode 100644
index 0000000..0f142cf
--- /dev/null
+++ b/build/lucid-script.lisp
@@ -0,0 +1,82 @@
+
+; Script to load the Scheme 48 linker into Common Lisp.
+; Requires Pseudoscheme 2.11.
+
+(defvar pseudoscheme-directory "../pseudo/")
+(load (concatenate 'string pseudoscheme-directory "loadit.lisp"))
+; or perhaps (load (merge-pathnames "loadit.lisp" pseudoscheme-directory))
+(load-pseudoscheme pseudoscheme-directory)
+
+(progn (revised^4-scheme::define-sharp-macro #\.
+	 #'(lambda (c port)
+	     (read-char port)
+	     (eval (let ((*readtable* ps::scheme-readtable))
+		     (read port)))))
+       (values))
+
+(ps:scheme)
+;--------------------
+; Scheme forms
+
+(benchmark-mode)
+
+(define config-env     ; (interaction-environment) would also work here.
+  (#.'scheme-translator:make-program-env
+     '%config
+     (list #.'scheme-translator:revised^4-scheme-structure)))
+
+(load "bcomp/module-language" config-env)
+(load "alt/config" config-env)
+(load "env/flatload" config-env)
+(eval '(set! *load-file-type* #f) config-env)
+
+(define load-config
+  (let ((load-config (eval 'load-configuration config-env)))
+    (lambda (filename)
+      (load-config filename config-env))))
+
+(load-config "packages")
+
+(define flatload-package (eval 'flatload config-env))
+
+(flatload-package (eval 'linker-structures config-env) config-env)
+
+(let ((#.'clever-load:*compile-if-necessary-p* #t))
+  (let ((#.'ps:*scheme-read* #.'#'ps::scheme-read-using-commonlisp-reader))
+    (load "alt/pseudoscheme-record")
+    (load "alt/pseudoscheme-features")))
+
+(let ((#.'clever-load:*compile-if-necessary-p* #t))
+  (flatload-package (eval 'link-config config-env)))
+
+(load "alt/init-defpackage.scm")
+
+(define-syntax struct-list    ;not in link.sbin
+  (syntax-rules ()
+    ((struct-list ?name ...) (list (cons '?name ?name) ...))))
+
+;--------------------
+(quit)
+
+#+Lucid
+(defun disksave-restart-function ()
+  (format t "~&Scheme 48 linker.~2%")
+  ;; (hax:init-interrupt-delivery)   - for threads
+  (ps:scheme)
+  (terpri))
+#+Lucid
+(defun dump-linker ()
+  (lcl:disksave "link/linker-in-lucid" :gc t :full-gc t :verbose t
+		:restart-function #'disksave-restart-function))
+;(dump-linker)
+;(lcl:quit)
+
+
+; Debugging hacks
+;(defun enable-lisp-packages ()
+;  (setq *readtable* ps:scheme-readtable)
+;  (values))
+;(defun disable-lisp-packages ()
+;  (setq *readtable* ps::roadblock-readtable)
+;  (values))
+
diff --git a/build/minor-version-number b/build/minor-version-number
new file mode 100644
index 0000000..59343b0
--- /dev/null
+++ b/build/minor-version-number
@@ -0,0 +1 @@
+53
diff --git a/c/c-mods.h b/c/c-mods.h
new file mode 100644
index 0000000..84130cb
--- /dev/null
+++ b/c/c-mods.h
@@ -0,0 +1,4 @@
+
+#define TRUE  (0 == 0)
+#define FALSE (0 == 1)
+#define	bool  char		/* boolean type */
diff --git a/c/event.h b/c/event.h
new file mode 100644
index 0000000..96874e5
--- /dev/null
+++ b/c/event.h
@@ -0,0 +1,33 @@
+enum event_enum { KEYBOARD_INTERRUPT_EVENT, IO_COMPLETION_EVENT, ALARM_EVENT,
+		    OS_SIGNAL_EVENT, ERROR_EVENT, NO_EVENT };
+
+extern bool s48_add_pending_fd(int fd, bool is_input);
+extern bool s48_remove_fd(int fd);
+
+extern long s48_schedule_alarm_interrupt(long delta);
+extern void s48_start_alarm_interrupts(void);
+extern void s48_stop_alarm_interrupts(void);
+
+extern long s48_run_time(long *mseconds);
+extern long s48_real_time(long *mseconds);
+extern int  s48_wait_for_event(long max_wait, bool is_minutes);
+extern int  s48_get_next_event(long *ready_fd, long *status);
+
+/* these are here only for the CHEAP_TIME() macro */
+#define TICKS_PER_SECOND 1000	/* clock resolution */
+#define POLLS_PER_SECOND   20   /* how often we poll */
+#define TICKS_PER_POLL  (TICKS_PER_SECOND / POLLS_PER_SECOND)
+
+extern long s48_current_time;
+#define CHEAP_TIME()  (s48_current_time * TICKS_PER_POLL)
+
+/*
+ * Fix (HCC) NOTE_EVENT so that it will act like a single
+ * statement.
+ */
+#define	NOTE_EVENT					\
+	do {						\
+		s48_Spending_eventsPS = 1;		\
+		s48_Spending_interruptPS = 1;		\
+	} while (0)
+
diff --git a/c/extension.c b/c/extension.c
new file mode 100644
index 0000000..ba54548
--- /dev/null
+++ b/c/extension.c
@@ -0,0 +1,236 @@
+/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
+   See file COPYING. */
+
+/* Implementation of the vm-extension opcode.  This is completely
+   optional; nothing in the standard system uses these features.
+   If you have ANSI C but not POSIX support, try compiling with -DPOSIX=0.
+
+   The vm-extension opcode is being phased out.  New code should use the
+   external-call opcode to call C procedures.
+
+   floating point: POSIX.1, ANSI C (should we be linking with -lM or -lm?)
+   sprintf: POSIX.1, ANSI C
+   atof: POSIX.1, ANSI C
+
+ */
+
+#ifndef POSIX
+#  define POSIX 2
+#endif
+
+#include <stdio.h>
+#include "sysdep.h"
+#include "scheme48.h"
+
+#include <string.h>
+#include <stdlib.h>
+#include <math.h>
+#include <signal.h>
+#include <unistd.h>		/* setuid & setgid */
+#include <errno.h>
+#include <netdb.h>		/* gethostbyname */  /* Kali code */
+
+#include <sys/types.h>
+#include <sys/wait.h>
+
+
+#define GREATEST_FIXNUM_VALUE ((1 << 29) - 1)
+#define LEAST_FIXNUM_VALUE (-1 << 29)
+#define CHANNEL_INDEX(x) EXTRACT_FIXNUM(STOB_REF(x, 1))
+#define FOR_INPUT 1
+#define FOR_OUTPUT 2
+
+typedef struct {
+  char b[sizeof(double)];
+} unaligned_double;
+
+typedef union {
+  double f;
+  unaligned_double b;
+} float_or_bytes;
+
+extern long s48_Sextension_valueS;  /* how values are returned */
+
+/* return status values */
+#define EXT_ST_OKAY 0
+#define EXT_ST_EXCEPTION 1
+
+#define EXT_RETURN(value) {s48_Sextension_valueS = (value); return EXT_ST_OKAY; }
+#define EXT_EXCEPTION     return EXT_ST_EXCEPTION
+
+/******************************************/
+
+s48_value
+s48_extended_vm (long key, s48_value value)
+{
+  double x, y;
+
+  switch (key) {
+
+    /* Cases 0 through 19 are reserved for the mobot system. */
+
+  case 0:			/* read jumpers on 68000 board */
+    EXT_RETURN(S48_UNSAFE_ENTER_FIXNUM(0));
+
+  /* Floating point */
+
+#define FLOP 100
+#define FLOP2(i) case FLOP+(i): \
+		   if (!S48_STOB_P(value) || S48_STOB_DESCRIPTOR_LENGTH(value) != 2) \
+		     EXT_EXCEPTION;
+#define FLOP3(i) case FLOP+(i): \
+		   if (!S48_STOB_P(value) || S48_STOB_DESCRIPTOR_LENGTH(value) != 3) \
+		     EXT_EXCEPTION;
+
+#define get_arg(args,i) S48_STOB_REF(args,(i))
+#define get_string_arg(args,i) (S48_UNSAFE_EXTRACT_STRING(get_arg(args,i)))
+
+#define get_float_arg(args, i, var) EXTRACT_FLOAT(get_arg(args, i), var)
+#define set_float_arg(args, i, val) SET_FLOAT(get_arg(args, i), val)
+
+#define EXTRACT_FLOAT(stob, var) \
+  { s48_value temp_ = (stob); \
+    float_or_bytes loser_; \
+    if (!S48_STOB_P(temp_)) EXT_EXCEPTION; \
+    loser_.b = *(unaligned_double*)(&S48_STOB_REF(temp_, 0)); \
+    (var) = loser_.f; }
+
+#define SET_FLOAT(stob, val) \
+  { s48_value temp_ = (stob); \
+    float_or_bytes loser_; \
+    if (!S48_STOB_P(temp_)) EXT_EXCEPTION; \
+    loser_.f = (double)(val); \
+    *(unaligned_double*)(&S48_STOB_REF(temp_, 0)) = loser_.b; }
+
+  FLOP3(0) {
+    get_float_arg(value, 0, x);
+    get_float_arg(value, 1, y);
+    set_float_arg(value, 2, x + y);
+    EXT_RETURN(S48_UNSPECIFIC);}
+  FLOP3(1) {
+    get_float_arg(value, 0, x);
+    get_float_arg(value, 1, y);
+    set_float_arg(value, 2, x - y);
+    EXT_RETURN(S48_UNSPECIFIC);}
+  FLOP3(2) {
+    get_float_arg(value, 0, x);
+    get_float_arg(value, 1, y);
+    set_float_arg(value, 2, x * y);
+    EXT_RETURN(S48_UNSPECIFIC);}
+  FLOP3(3) {
+    get_float_arg(value, 0, x);
+    get_float_arg(value, 1, y);
+    if (y == 0.0) EXT_EXCEPTION;
+    set_float_arg(value, 2, x / y);
+    EXT_RETURN(S48_UNSPECIFIC);}
+  FLOP2(4) {
+    get_float_arg(value, 0, x);
+    get_float_arg(value, 1, y);
+    EXT_RETURN(S48_ENTER_BOOLEAN(x == y));}
+  FLOP2(5) {
+    get_float_arg(value, 0, x);
+    get_float_arg(value, 1, y);
+    EXT_RETURN(S48_ENTER_BOOLEAN(x < y));}
+  FLOP2(6) {			/* fixnum->float */
+    s48_value arg = get_arg(value, 0);
+    if (!S48_FIXNUM_P(arg)) EXT_RETURN(S48_FALSE);
+    set_float_arg(value, 1, S48_UNSAFE_EXTRACT_FIXNUM(arg));
+    EXT_RETURN(S48_TRUE);}
+  FLOP2(7) {			/* string->float */
+    char *str = get_string_arg(value, 0);
+    set_float_arg(value, 1, atof(str));
+    EXT_RETURN(S48_UNSPECIFIC);}
+  FLOP2(8) {			/* float->string */
+    size_t len;
+    char *str = get_string_arg(value,1);
+    get_float_arg(value, 0, x);
+    sprintf(str, "%g", x);
+    len = strlen(str);
+    if (len > S48_UNSAFE_STRING_LENGTH(get_arg(value,1)))
+      /* unlikely but catastrophic */
+      fprintf(stderr, "printing float: output too long: %s\n",
+	      str);
+    EXT_RETURN(S48_UNSAFE_ENTER_FIXNUM(len));}
+
+    /* exp log sin cos tan asin acos atan sqrt */
+
+  FLOP2(9) {
+    get_float_arg(value, 0, x);
+    set_float_arg(value, 1, exp(x));
+    EXT_RETURN(S48_UNSPECIFIC);}
+  FLOP2(10) {
+    get_float_arg(value, 0, x);
+    set_float_arg(value, 1, log(x));
+    EXT_RETURN(S48_UNSPECIFIC);}
+  FLOP2(11) {
+    get_float_arg(value, 0, x);
+    set_float_arg(value, 1, sin(x));
+    EXT_RETURN(S48_UNSPECIFIC);}
+  FLOP2(12) {
+    get_float_arg(value, 0, x);
+    set_float_arg(value, 1, cos(x));
+    EXT_RETURN(S48_UNSPECIFIC);}
+  FLOP2(13) {
+    get_float_arg(value, 0, x);
+    set_float_arg(value, 1, tan(x));
+    EXT_RETURN(S48_UNSPECIFIC);}
+  FLOP2(14) {
+    get_float_arg(value, 0, x);
+    set_float_arg(value, 1, asin(x));
+    EXT_RETURN(S48_UNSPECIFIC);}
+  FLOP2(15) {
+    get_float_arg(value, 0, x);
+    set_float_arg(value, 1, acos(x));
+    EXT_RETURN(S48_UNSPECIFIC);}
+  FLOP3(16) {			/* atan */
+    get_float_arg(value, 0, y);
+    get_float_arg(value, 1, x);
+    set_float_arg(value, 2, atan2(y, x));
+    EXT_RETURN(S48_UNSPECIFIC);}
+  FLOP2(17) {
+    get_float_arg(value, 0, x);
+    set_float_arg(value, 1, sqrt(x));
+    EXT_RETURN(S48_UNSPECIFIC);}
+
+  FLOP2(18) {			/* floor */
+    get_float_arg(value, 0, x);
+    set_float_arg(value, 1, floor(x));
+    EXT_RETURN(S48_UNSPECIFIC);}
+  case FLOP+19: {		/* integer? */
+    EXTRACT_FLOAT(value, x);
+    EXT_RETURN(S48_ENTER_BOOLEAN(fmod(x, 1.0) == 0.0)); }
+  case FLOP+20: {		/* float->fixnum */
+    EXTRACT_FLOAT(value, x);
+    if (x <= (double)GREATEST_FIXNUM_VALUE
+	&& x >= (double)LEAST_FIXNUM_VALUE)
+      {
+      EXT_RETURN(S48_UNSAFE_ENTER_FIXNUM((long)x)); }
+    else
+      EXT_RETURN(S48_FALSE);}
+  FLOP3(21) {			/* quotient */
+    double z;
+    get_float_arg(value, 0, x);
+    get_float_arg(value, 1, y);
+    if (fmod(x, 1.0) != 0.0 || fmod(y, 1.0) != 0.0) EXT_EXCEPTION;
+    if (y == 0.0) EXT_EXCEPTION;
+    z = x / y;
+    set_float_arg(value, 2, z < 0.0 ? ceil(z) : floor(z));
+    EXT_RETURN(S48_UNSPECIFIC);}
+  FLOP3(22) {			/* remainder */
+    get_float_arg(value, 0, x);
+    get_float_arg(value, 1, y);
+    if (fmod(x, 1.0) != 0.0 || fmod(y, 1.0) != 0.0) EXT_EXCEPTION;
+    if (y == 0.0) EXT_EXCEPTION;
+
+    /* "fmod(double x, double y) returns the floating-point remainder
+       (f) of the division of x by y, where f has the same sign as x,
+       such that x=iy+f for some integer i, and |f| < |y|." */
+
+    set_float_arg(value, 2, fmod(x, y));
+    EXT_RETURN(S48_UNSPECIFIC);}
+
+  default:
+    EXT_EXCEPTION;
+  }
+}
+
diff --git a/c/external.c b/c/external.c
new file mode 100644
index 0000000..ffc0037
--- /dev/null
+++ b/c/external.c
@@ -0,0 +1,947 @@
+/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
+   See file COPYING. */
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <setjmp.h>
+#include <stdarg.h>
+
+#include "c-mods.h"
+#include "scheme48.h"
+#include "scheme48vm.h"
+
+/*
+ * The Joy of C
+ * I don't understand why we need this, but we do.
+ */
+
+struct s_jmp_buf {
+  jmp_buf buf;
+};
+
+/*
+ * Longjump target set up by the most recent call into C.
+ */
+static struct s_jmp_buf	current_return_point;
+
+/*
+ * The name of the procedure we are currently executing; used for error messages.
+ */
+static s48_value current_procedure;
+
+/*
+ * Stack of Scheme stack-block records which represent portions of the process
+ * stack.
+ */
+static s48_value current_stack_block = S48_FALSE;
+
+/*
+ * These need to agree with the record definition in callback.scm.
+ */
+#define STACK_BLOCK_FREE(stack_block)	S48_UNSAFE_RECORD_REF(stack_block, 0)
+#define STACK_BLOCK_UNWIND(stack_block)	S48_UNSAFE_RECORD_REF(stack_block, 1)
+#define STACK_BLOCK_PROC(stack_block)	S48_UNSAFE_RECORD_REF(stack_block, 2)
+#define STACK_BLOCK_THREAD(stack_block)	S48_UNSAFE_RECORD_REF(stack_block, 3)
+#define STACK_BLOCK_NEXT(stack_block)	S48_UNSAFE_RECORD_REF(stack_block, 4)
+
+/*
+ * For debugging.
+ */
+/*
+static int callback_depth()
+{
+  int depth = 0;
+  s48_value stack = current_stack_block;
+
+  for(; stack != S48_FALSE; depth++, stack = STACK_BLOCK_NEXT(stack));
+
+  return depth;
+}
+*/
+/*
+ * The value being returned from an external call.  The returns may be preceded
+ * by a longjmp(), so we stash the value here.
+ */
+static s48_value external_return_value;
+
+/* Exports to Scheme */
+static s48_value	s48_clear_stack_top(void);
+static s48_value	s48_trampoline(s48_value proc, s48_value nargs);
+
+/* Imports from Scheme */
+static s48_value 	the_record_type_binding = S48_FALSE;
+static s48_value 	stack_block_type_binding = S48_FALSE;
+static s48_value 	callback_binding = S48_FALSE;
+static s48_value 	delay_callback_return_binding = S48_FALSE;
+static s48_value 	bignum_to_long_binding = S48_FALSE;
+static s48_value 	long_to_bignum_binding = S48_FALSE;
+
+void
+s48_initialize_external()
+{
+  S48_GC_PROTECT_GLOBAL(the_record_type_binding);
+  the_record_type_binding = s48_get_imported_binding("s48-the-record-type");
+
+  S48_GC_PROTECT_GLOBAL(stack_block_type_binding);
+  stack_block_type_binding = s48_get_imported_binding("s48-stack-block-type");
+
+  S48_GC_PROTECT_GLOBAL(callback_binding);
+  callback_binding = s48_get_imported_binding("s48-callback");
+
+  S48_GC_PROTECT_GLOBAL(delay_callback_return_binding);
+  delay_callback_return_binding =
+    s48_get_imported_binding("s48-delay-callback-return");
+
+  S48_GC_PROTECT_GLOBAL(bignum_to_long_binding);
+  bignum_to_long_binding = s48_get_imported_binding("s48-bignum-to-long");
+
+  S48_GC_PROTECT_GLOBAL(long_to_bignum_binding);
+  long_to_bignum_binding = s48_get_imported_binding("s48-long-to-bignum");
+
+  S48_GC_PROTECT_GLOBAL(current_stack_block);
+  S48_GC_PROTECT_GLOBAL(current_procedure);
+
+  S48_EXPORT_FUNCTION(s48_clear_stack_top);
+  S48_EXPORT_FUNCTION(s48_trampoline);
+
+}
+
+/* The three reasons for an extern-call longjump. */
+
+#define NO_THROW        0
+#define EXCEPTION_THROW 1
+#define CLEANUP_THROW   2
+
+/*
+ * Used to call `proc' from Scheme code. `nargs' the number of arguments in
+ * vector `argv'.  If `spread_p' is true the procedure is applied to the
+ * arguments, otherwise `proc' is just called on `nargs' and `argv'.
+ *
+ * We do a setjmp() to get a return point for clearing off this portion of
+ * the process stack.  This is used when `proc' calls back to Scheme and
+ * then a throw transfers control up past the call to `proc'.
+ */
+
+s48_value
+s48_external_call(s48_value sch_proc, s48_value proc_name,
+		  long nargs, char *char_argv)
+{
+  volatile char *gc_roots_marker;	/* volatile to survive longjumps */
+  volatile s48_value name = proc_name;	/* volatile to survive longjumps */
+  
+  /* int depth = callback_depth(); */	/* debugging */
+
+  long *argv = (long *) char_argv;
+
+  s48_value (*proc)() = (s48_value (*)())
+                         *S48_EXTRACT_VALUE_POINTER(sch_proc, long);
+
+  int throw_reason;
+
+  current_procedure = name;
+
+  S48_CHECK_VALUE(sch_proc);
+  S48_CHECK_STRING(name);
+
+  gc_roots_marker = s48_set_gc_roots_baseB();
+
+  /* fprintf(stderr, "[external_call at depth %d]\n", depth); */
+
+  throw_reason = setjmp(current_return_point.buf);
+
+  if (throw_reason == NO_THROW) {	/* initial entry */
+    switch (nargs) {
+    case 0:
+      external_return_value = proc();
+      break;
+    case 1:
+      external_return_value = proc(argv[0]);
+      break;
+    case 2:
+      external_return_value = proc(argv[1], argv[0]);
+      break;
+    case 3:
+      external_return_value = proc(argv[2], argv[1], argv[0]);
+      break;
+    case 4:
+      external_return_value = proc(argv[3], argv[2], argv[1], argv[0]);
+      break;
+    case 5:
+      external_return_value = proc(argv[4],
+				   argv[3], argv[2], argv[1], argv[0]);
+      break;
+    case 6:
+      external_return_value = proc(argv[5], argv[4],
+				   argv[3], argv[2], argv[1], argv[0]);
+      break;
+    case 7:
+      external_return_value = proc(argv[6], argv[5], argv[4],
+				   argv[3], argv[2], argv[1], argv[0]);
+      break;
+    case 8:
+      external_return_value = proc(argv[7], argv[6], argv[5], argv[4],
+				   argv[3], argv[2], argv[1], argv[0]);
+      break;
+    case 9:
+      external_return_value = proc(argv[8],
+				   argv[7], argv[6], argv[5], argv[4],
+				   argv[3], argv[2], argv[1], argv[0]);
+      break;
+    case 10:
+      external_return_value = proc(argv[9], argv[8],
+				   argv[7], argv[6], argv[5], argv[4],
+				   argv[3], argv[2], argv[1], argv[0]);
+      break;
+    case 11:
+      external_return_value = proc(argv[10], argv[9], argv[8],
+				   argv[7], argv[6], argv[5], argv[4],
+				   argv[3], argv[2], argv[1], argv[0]);
+      break;
+    case 12:
+      external_return_value = proc(argv[11], argv[10], argv[9], argv[8],
+				   argv[7], argv[6], argv[5], argv[4],
+				   argv[3], argv[2], argv[1], argv[0]);
+      break;
+    default:
+      fprintf(stderr, "external-apply called with too many arguments");
+      exit(-1); }
+
+    /* Raise an exception if the user neglected to pop off some gc roots. */
+    
+    if (! s48_release_gc_roots_baseB((char *)gc_roots_marker)) {
+      s48_raise_scheme_exception(S48_EXCEPTION_GC_PROTECTION_MISMATCH, 0);
+    }
+    
+    /* Clear any free stack-blocks off of the top of the stack-block stack and
+       then longjmp past the corresponding portions of the process stack. */
+    
+    if (current_stack_block != S48_FALSE &&
+	STACK_BLOCK_FREE(current_stack_block) == S48_TRUE) {
+
+      s48_value bottom_free_block;
+      
+      do {
+	bottom_free_block = current_stack_block;
+	current_stack_block = STACK_BLOCK_NEXT(current_stack_block);
+      }
+      while (current_stack_block != S48_FALSE &&
+	     STACK_BLOCK_FREE(current_stack_block) == S48_TRUE);
+      
+      /* fprintf(stderr, "[Freeing stack blocks from %d to %d]\n",
+	                 depth,
+	                 callback_depth()); */
+
+      longjmp(S48_EXTRACT_VALUE_POINTER(STACK_BLOCK_UNWIND(bottom_free_block),
+					struct s_jmp_buf)->buf,
+	      CLEANUP_THROW);
+    }
+  }
+  else {	/* throwing an exception or uwinding the stack */
+    /* fprintf(stderr, "[external_call throw; was %d and now %d]\n",
+                       depth,
+                      callback_depth());
+     fprintf(stderr, "[throw unrolling to %ld]\n", gc_roots_marker); */
+    s48_release_gc_roots_baseB((char *)gc_roots_marker);
+  }
+
+  /* Check to see if a thread is waiting to return to the next block down. */
+     
+  if (current_stack_block != S48_FALSE &&
+      STACK_BLOCK_THREAD(current_stack_block) != S48_FALSE) {
+    /* fprintf(stderr, "[releasing return at %d]\n", callback_depth()); */
+
+    if (throw_reason == EXCEPTION_THROW) {
+      /* We are in the midst of raising an exception, so we need to piggyback
+	 our exception on that one. */
+      s48_value old_exception
+	= s48_resetup_external_exception(S48_EXCEPTION_CALLBACK_RETURN_UNCOVERED,
+					 2);
+      s48_push(old_exception);
+      s48_push(current_stack_block);
+      external_return_value = S48_UNSPECIFIC;
+    }
+    else {
+      s48_setup_external_exception(S48_EXCEPTION_CALLBACK_RETURN_UNCOVERED, 2);
+      s48_push(current_stack_block);
+      s48_push(external_return_value);
+      external_return_value = S48_UNSPECIFIC;
+    }
+  }
+  
+  return external_return_value;
+}
+
+/*
+ * Call Scheme function `proc' from C.  We push the call-back depth, `proc',
+ * and the arguments on the Scheme stack and then restart the VM.  The restarted
+ * VM calls the Scheme procedure `callback' which wraps the call to `proc' with
+ * a dynamic-wind.  This prevents downward throws back into the call to `proc',
+ * which C can't handle, and allows the C stack to be cleaned up if an upward
+ * throw occurs.
+ *
+ * The maximum number of arguments is determined by the amount of space reserved
+ * on the Scheme stack for exceptions. See the definition of stack-slack in
+ * scheme/vm/stack.scm.
+ */
+s48_value
+s48_call_scheme(s48_value proc, long nargs, ...)
+{
+  int i;
+  va_list arguments;
+  s48_value value;
+  s48_value unwind, stack_block;
+  S48_DECLARE_GC_PROTECT(2);
+
+  S48_GC_PROTECT_2(unwind, proc);
+  
+  va_start(arguments, nargs);
+
+  S48_SHARED_BINDING_CHECK(callback_binding);
+
+  /* It would be nice to push a list of the arguments, but we have no way
+     of preserving them across a cons. */
+  if (nargs < 0 || 10 < nargs) {  /* DO NOT INCREASE THIS NUMBER */
+    s48_value sch_nargs = s48_enter_integer(nargs);  /* `proc' is protected */
+    s48_raise_scheme_exception(S48_EXCEPTION_TOO_MANY_ARGUMENTS_IN_CALLBACK,
+			       2, proc, sch_nargs);
+  }
+
+  /* fprintf(stderr, "[s48_call, %ld args, depth %d]\n",
+	  nargs, callback_depth()); */
+
+  s48_push(S48_UNSPECIFIC);	/* placeholder */
+  s48_push(proc);
+  for (i = 0; i < nargs; i++)
+    s48_push(va_arg(arguments, s48_value));
+
+  va_end(arguments);
+
+  /* With everything safely on the stack we can do the necessary allocation. */
+
+  unwind = S48_MAKE_VALUE(struct s_jmp_buf);
+  S48_EXTRACT_VALUE(unwind, struct s_jmp_buf) = current_return_point;
+
+  stack_block = s48_make_record(stack_block_type_binding);
+  STACK_BLOCK_UNWIND(stack_block) = unwind;
+  STACK_BLOCK_PROC(stack_block) = current_procedure;
+  STACK_BLOCK_NEXT(stack_block) = current_stack_block;
+  STACK_BLOCK_FREE(stack_block) = S48_FALSE;
+  STACK_BLOCK_THREAD(stack_block) = S48_FALSE;
+
+  S48_GC_UNPROTECT();		/* no more references to `unwind' or `proc'. */
+
+  current_stack_block = stack_block;
+
+  /* if(s48_stack_ref(nargs + 1) != S48_UNSPECIFIC)
+     fprintf(stderr, "[stack_block set missed]\n"); */
+
+  s48_stack_setB(nargs + 1, stack_block);
+
+  /* fprintf(stderr, "[s48_call, %ld args, depth %d, off we go]\n",
+	  nargs, callback_depth()); */
+
+  value = s48_restart(S48_UNSAFE_SHARED_BINDING_REF(callback_binding),
+		      nargs + 2);
+
+  for (;s48_Scallback_return_stack_blockS != current_stack_block;) {
+    if (s48_Scallback_return_stack_blockS == S48_FALSE) {
+
+      /* fprintf(stderr, "[s48_call returning from VM %ld]\n", callback_depth()); */
+
+      exit(value);
+    }
+    else {
+
+      /* Someone has returned (because of threads) to the wrong section of the
+	 C stack.  We call back to a Scheme procedure that will suspend until
+	 out block is at the top of the stack. */
+
+      s48_push(s48_Scallback_return_stack_blockS);
+      s48_push(S48_UNSAFE_SHARED_BINDING_REF(delay_callback_return_binding));
+      s48_push(s48_Scallback_return_stack_blockS);
+      s48_push(value);
+
+      /* fprintf(stderr, "[Premature return, %ld args, depth %d, back we go]\n",
+	      nargs, callback_depth()); */
+
+      s48_disable_interruptsB();
+      value = s48_restart(S48_UNSAFE_SHARED_BINDING_REF(callback_binding), 4);
+    }
+  }
+
+  /* Restore the state of the current stack block. */
+
+  unwind = STACK_BLOCK_UNWIND(current_stack_block);
+  current_return_point = S48_EXTRACT_VALUE(unwind, struct s_jmp_buf);
+  current_procedure = STACK_BLOCK_PROC(current_stack_block);
+  current_stack_block = STACK_BLOCK_NEXT(current_stack_block);
+
+  /* fprintf(stderr, "[s48_call returns from depth %d]\n", callback_depth()); */
+
+  return value;
+}
+
+/*
+ * Because the top of the stack is cleared on the return from every external
+ * call, this doesn't have to do anything but exist.
+ */
+static s48_value
+s48_clear_stack_top()
+{
+  /* fprintf(stderr, "[Clearing stack top]\n"); */
+  return S48_UNSPECIFIC;
+}
+
+/*
+ * For testing callbacks.  This just calls its argument on the specified number
+ * of values.
+ */
+static s48_value
+s48_trampoline(s48_value proc, s48_value nargs)
+{
+
+  fprintf(stderr, "[C trampoline, %ld args]\n", S48_UNSAFE_EXTRACT_FIXNUM(nargs));
+
+  switch (s48_extract_fixnum(nargs)) {
+  case -2: {
+    S48_DECLARE_GC_PROTECT(1);
+    
+    S48_GC_PROTECT_1(proc);
+
+    return S48_FALSE;
+  }
+  case -1: {
+    long n = - s48_extract_integer(proc);
+    fprintf(stderr, "[extract magnitude is %ld (%lx)]\n", n, n);
+    return s48_enter_integer(n);
+  }
+  case 0: {
+    s48_value value = s48_call_scheme(proc, 0);
+    if (value == S48_FALSE)
+      s48_raise_string_os_error("trampoline bouncing");
+    return value;
+  }
+  case 1:
+    return s48_call_scheme(proc, 1, s48_enter_fixnum(100));
+  case 2:
+    return s48_call_scheme(proc, 2, s48_enter_fixnum(100), s48_enter_fixnum(200));
+  case 3:
+    return s48_call_scheme(proc, 3, s48_enter_fixnum(100), s48_enter_fixnum(200),
+		    s48_enter_fixnum(300));
+  default:
+    s48_raise_range_error(nargs, s48_enter_fixnum(0), s48_enter_fixnum(3));
+    return S48_UNDEFINED; /* not that we ever get here */
+  }
+}
+
+/********************************/
+/*
+ * Raising exceptions.  We push the arguments on the stack end then throw out
+ * of the most recent call from Scheme.
+ *
+ * The maximum number of arguments is determined by the amount of space reserved
+ * on the Scheme stack for exceptions. See the definition of stack-slack in
+ * scheme/vm/stack.scm.
+ */
+void
+s48_raise_scheme_exception(long why, long nargs, ...)
+{
+  int i;
+  va_list irritants;
+
+  va_start(irritants, nargs);
+
+  s48_setup_external_exception(why, nargs + 1);
+  
+  if (10 < nargs) {   /* DO NOT INCREASE THIS NUMBER */
+    fprintf(stderr, "s48_raise_scheme_exception() called with more than 10 arguments, discarding surplus\n");
+    nargs = 10;
+  }
+  
+  s48_push(current_procedure);
+
+  for (i = 0; i < nargs; i++)
+    s48_push(va_arg(irritants, s48_value));
+
+  va_end(irritants);
+
+   external_return_value = S48_UNSPECIFIC;
+   longjmp(current_return_point.buf, EXCEPTION_THROW);
+}
+
+/* Specific exceptions */
+
+void
+s48_raise_argtype_error(s48_value value) {
+  s48_raise_scheme_exception(S48_EXCEPTION_WRONG_TYPE_ARGUMENT, 1, value);
+}
+
+void
+s48_raise_argnumber_error(s48_value value, s48_value min, s48_value max) {
+  s48_raise_scheme_exception(S48_EXCEPTION_WRONG_NUMBER_OF_ARGUMENTS,
+			     3, value, min, max);
+}
+
+void
+s48_raise_range_error(s48_value value, s48_value min, s48_value max) {
+  s48_raise_scheme_exception(S48_EXCEPTION_INDEX_OUT_OF_RANGE,
+			     3, value, min, max);
+}
+
+void
+s48_raise_closed_channel_error() {
+  s48_raise_scheme_exception(S48_EXCEPTION_CLOSED_CHANNEL, 0);
+}
+
+void
+s48_raise_os_error(int the_errno) {
+  s48_raise_scheme_exception(S48_EXCEPTION_OS_ERROR, 2,
+			     s48_enter_fixnum(the_errno),
+			     s48_enter_string(strerror(the_errno)));
+}
+
+void
+s48_raise_string_os_error(char *reason) {
+  s48_raise_scheme_exception(S48_EXCEPTION_OS_ERROR, 1,
+			     s48_enter_string(reason));
+}
+
+void
+s48_raise_out_of_memory_error() {
+  s48_raise_scheme_exception(S48_EXCEPTION_OUT_OF_MEMORY, 0);
+}
+
+/********************************/
+/* Support routines for external code */
+
+/*
+ * Type-safe procedures for checking types and dereferencing and setting slots.
+ */
+
+int
+s48_stob_has_type(s48_value thing, int type)
+{
+  return S48_STOB_P(thing) && (S48_STOB_TYPE(thing) == type);
+}
+
+long
+s48_stob_length(s48_value thing, int type)
+{
+  if (!(S48_STOB_P(thing) && (S48_STOB_TYPE(thing) == type)))
+    s48_raise_argtype_error(thing);
+  
+  return S48_STOB_DESCRIPTOR_LENGTH(thing);
+}
+
+long
+s48_stob_byte_length(s48_value thing, int type)
+{
+  if (!(S48_STOB_P(thing) && (S48_STOB_TYPE(thing) == type)))
+    s48_raise_argtype_error(thing);
+
+  if (type == S48_STOBTYPE_STRING)
+    return S48_STOB_BYTE_LENGTH(thing) - 1;
+  else
+    return S48_STOB_BYTE_LENGTH(thing);
+}
+
+s48_value
+s48_stob_ref(s48_value thing, int type, long offset)
+{
+  long length;
+
+  if (!(S48_STOB_P(thing) && (S48_STOB_TYPE(thing) == type)))
+    s48_raise_argtype_error(thing);
+
+  length = S48_STOB_DESCRIPTOR_LENGTH(thing);
+
+  if (offset < 0 || length <= offset)
+    s48_raise_range_error(s48_enter_integer(offset),
+			  S48_UNSAFE_ENTER_FIXNUM(0),
+		          S48_UNSAFE_ENTER_FIXNUM(length - 1));
+			  
+  return S48_STOB_REF(thing, offset);
+}
+
+void
+s48_stob_set(s48_value thing, int type, long offset, s48_value value)
+{
+  long length;
+  
+  if (!(S48_STOB_P(thing) &&
+	(S48_STOB_TYPE(thing) == type) &&
+	!S48_STOB_IMMUTABLEP(thing)))
+    s48_raise_argtype_error(thing);
+  
+  length = S48_STOB_DESCRIPTOR_LENGTH(thing);
+
+  if (offset < 0 || length <= offset)
+    s48_raise_range_error(s48_enter_integer(offset),
+			  S48_UNSAFE_ENTER_FIXNUM(0),
+			  S48_UNSAFE_ENTER_FIXNUM(length - 1));
+			  
+  S48_STOB_SET(thing, offset, value);
+}
+
+char
+s48_byte_ref(s48_value thing, int type, long offset)
+{
+  long length;
+
+  if (!(S48_STOB_P(thing) && (S48_STOB_TYPE(thing) == type)))
+    s48_raise_argtype_error(thing);
+  
+  length = (type == S48_STOBTYPE_STRING) ?
+           S48_STOB_BYTE_LENGTH(thing) - 1 :
+           S48_STOB_BYTE_LENGTH(thing);
+  
+  if (offset < 0 || length <= offset)
+    s48_raise_range_error(s48_enter_integer(offset),
+			  S48_UNSAFE_ENTER_FIXNUM(0),
+			  S48_UNSAFE_ENTER_FIXNUM(length - 1));
+			  
+  return S48_STOB_BYTE_REF(thing, offset);
+}
+
+void
+s48_byte_set(s48_value thing, int type, long offset, char value)
+{
+  long length;
+
+  if (!(S48_STOB_P(thing) && (S48_STOB_TYPE(thing) == type)))
+    s48_raise_argtype_error(thing);
+  
+  length = (type == S48_STOBTYPE_STRING) ?
+           S48_STOB_BYTE_LENGTH(thing) - 1 :
+           S48_STOB_BYTE_LENGTH(thing);
+  
+  if (offset < 0 || length <= offset)
+    s48_raise_range_error(s48_enter_integer(offset),
+			  S48_UNSAFE_ENTER_FIXNUM(0),
+			  S48_UNSAFE_ENTER_FIXNUM(length - 1));
+			  
+  S48_STOB_BYTE_SET(thing, offset, value);
+}
+
+void *
+s48_value_pointer(s48_value value)
+{
+  S48_CHECK_VALUE(value);
+
+  return S48_ADDRESS_AFTER_HEADER(value, void *);
+}
+
+/********************************/
+/* Numbers, characters, and pointers. */
+
+/*
+ * These two functions have the same range as the unsafe macros, but they signal
+ * an error if things go wrong, instead of silently producing garbage.  Unlike
+ * the integer versions they cannot cause a GC.
+ */
+
+s48_value
+s48_enter_fixnum(long value)
+{
+  if (value < S48_MIN_FIXNUM_VALUE || S48_MAX_FIXNUM_VALUE < value)
+    s48_raise_argtype_error(s48_enter_integer(value));
+
+  return S48_UNSAFE_ENTER_FIXNUM(value);
+}
+
+long
+s48_extract_fixnum(s48_value value)
+{
+  if (! S48_FIXNUM_P(value))
+    s48_raise_argtype_error(value);
+  
+  return S48_UNSAFE_EXTRACT_FIXNUM(value);
+}
+
+/*
+ * If `value' fits in a fixnum we put it there.  Larger values are passed to the
+ * Scheme procedure LONG-TO-BIGNUM as the sign and the two sixteen-bit halves of
+ * the negative magnitude.  Using the negative magnitude avoids problems with
+ * two's complement's asymmetry.
+ */
+
+s48_value
+s48_enter_integer(long value)
+{
+  if (S48_MIN_FIXNUM_VALUE <= value && value <= S48_MAX_FIXNUM_VALUE)
+    return S48_UNSAFE_ENTER_FIXNUM(value);
+  else {
+    S48_SHARED_BINDING_CHECK(long_to_bignum_binding);
+
+    if (value < 0)
+      return s48_call_scheme(S48_SHARED_BINDING_REF(long_to_bignum_binding),
+			     3,
+			     S48_FALSE,
+			     S48_UNSAFE_ENTER_FIXNUM(value >> 16),
+			     S48_UNSAFE_ENTER_FIXNUM(value & 0xFFFF));
+    else
+      return s48_call_scheme(S48_SHARED_BINDING_REF(long_to_bignum_binding),
+			     3,
+			     S48_TRUE,
+			     S48_UNSAFE_ENTER_FIXNUM((- value) >> 16),
+			     S48_UNSAFE_ENTER_FIXNUM((- value) & 0xFFFF));
+  }
+}
+
+/*
+ * If we have a fixnum we just extract it.  Bignums require a call back into
+ * Scheme 48.  (BIGNUM-TO-LONG n) returns a vector containing the sign and the
+ * high and low sixteen-bit halves of N.  If N is not an integer we get #f back.
+ * Again, we use negative numbers to stay out of trouble.
+ */
+
+long
+s48_extract_integer(s48_value value)
+{
+  if (S48_FIXNUM_P(value))
+    return S48_UNSAFE_EXTRACT_FIXNUM(value);
+
+  else {
+    s48_value stuff;
+    S48_DECLARE_GC_PROTECT(1);
+
+    S48_GC_PROTECT_1(value);
+
+    S48_SHARED_BINDING_CHECK(bignum_to_long_binding);
+
+    stuff = s48_call_scheme(S48_SHARED_BINDING_REF(bignum_to_long_binding),
+			    1,
+			    value);
+
+    S48_GC_UNPROTECT();
+
+    if (stuff == S48_FALSE)
+      s48_raise_argtype_error(value);
+
+    /* The first VECTOR_REF does the type checking for the rest. */
+    {
+      long low  = S48_UNSAFE_EXTRACT_FIXNUM(S48_VECTOR_REF(stuff, 2));
+      s48_value boxed_high = S48_UNSAFE_VECTOR_REF(stuff, 1);
+      long high = S48_UNSAFE_EXTRACT_FIXNUM(boxed_high);
+      int pos_p = S48_EXTRACT_BOOLEAN(S48_UNSAFE_VECTOR_REF(stuff, 0));
+      
+      if ((! S48_FIXNUM_P(boxed_high)) ||
+	  high > (pos_p ? 0x7FFF : 0x8000))
+	s48_raise_argtype_error(value);
+      
+      {
+      long magnitude = ((- high) << 16) - low;
+      return pos_p ? - magnitude : magnitude;
+      }
+    }
+  }
+}
+
+/*
+ * Doubles and characters are straightforward.
+ */
+
+s48_value
+s48_enter_double(double value)
+{
+  s48_value obj;
+
+  obj = s48_allocate_stob(S48_STOBTYPE_DOUBLE, sizeof(double));
+  S48_UNSAFE_EXTRACT_DOUBLE(obj) = value;
+
+  return obj;
+}
+
+double
+s48_extract_double(s48_value s48_double)
+{
+  if (! S48_DOUBLE_P(s48_double))
+    s48_raise_argtype_error(s48_double);
+  
+  return S48_UNSAFE_EXTRACT_DOUBLE(s48_double);
+}
+
+s48_value
+s48_enter_char(unsigned char a_char)
+{
+  if (a_char > 255)
+    s48_raise_range_error(s48_enter_fixnum(a_char),
+			  s48_enter_fixnum(0),
+			  s48_enter_fixnum(255));
+
+  return S48_UNSAFE_ENTER_CHAR(a_char);
+}
+
+unsigned char
+s48_extract_char(s48_value a_char)
+{
+  if (! S48_CHAR_P(a_char))
+    s48_raise_argtype_error(a_char);
+  
+  return S48_UNSAFE_EXTRACT_CHAR(a_char);
+}
+  
+/********************************/
+/* Allocation */
+
+s48_value
+s48_enter_pointer(void *pointer)
+{
+  s48_value obj;
+
+  obj = s48_allocate_stob(S48_STOBTYPE_BYTE_VECTOR, sizeof(void *));
+  *(S48_ADDRESS_AFTER_HEADER(obj, void **)) = pointer;
+
+  return obj;
+}
+
+s48_value
+s48_cons(s48_value v1, s48_value v2)
+{
+  s48_value obj;
+  S48_DECLARE_GC_PROTECT(2);
+
+  S48_GC_PROTECT_2(v1, v2);
+
+  obj = s48_allocate_stob(S48_STOBTYPE_PAIR, 2 * sizeof(s48_value));
+  S48_UNSAFE_SET_CAR(obj, v1);
+  S48_UNSAFE_SET_CDR(obj, v2);
+
+  S48_GC_UNPROTECT();
+  return obj;
+}
+
+s48_value
+s48_make_weak_pointer(s48_value value)
+{
+  s48_value obj;
+  S48_DECLARE_GC_PROTECT(1);
+
+  S48_GC_PROTECT_1(value);
+
+  obj = s48_allocate_stob(S48_STOBTYPE_WEAK_POINTER, sizeof(s48_value));
+  S48_STOB_SET(obj, 0, value);
+
+  S48_GC_UNPROTECT();
+  return obj;
+}
+
+s48_value
+s48_enter_substring(char *str, int length)
+{
+  s48_value obj = s48_allocate_stob(S48_STOBTYPE_STRING, length + 1);
+  strncpy(S48_UNSAFE_EXTRACT_STRING(obj), str, length);
+  *(S48_UNSAFE_EXTRACT_STRING(obj) + length) = '\0';
+  return obj;
+}
+
+s48_value
+s48_enter_string(char *str)
+{
+  return s48_enter_substring(str, strlen(str));
+}
+
+char *
+s48_extract_string(s48_value string)
+{
+  S48_CHECK_STRING(string);
+
+  return S48_UNSAFE_EXTRACT_STRING(string);
+}
+
+s48_value
+s48_make_string(int length, char init)
+{
+  s48_value obj = s48_allocate_stob(S48_STOBTYPE_STRING, length+1);
+  memset(S48_UNSAFE_EXTRACT_STRING(obj), init, length);
+  S48_UNSAFE_EXTRACT_STRING(obj)[length] = '\0';
+  return obj;
+}
+
+s48_value
+s48_make_vector(int length, s48_value init)
+{
+  int i;
+  s48_value obj;
+  S48_DECLARE_GC_PROTECT(1);
+
+  S48_GC_PROTECT_1(init);
+
+  obj = s48_allocate_stob(S48_STOBTYPE_VECTOR, length * sizeof(s48_value));
+  for (i = 0; i < length; ++i)
+    S48_UNSAFE_VECTOR_SET(obj, i, init);
+
+  S48_GC_UNPROTECT();
+
+  return obj;
+}
+
+s48_value
+s48_make_byte_vector(int length)
+{
+    return s48_allocate_stob(S48_STOBTYPE_BYTE_VECTOR, length);
+}
+
+s48_value
+s48_make_record(s48_value type_shared_binding)
+{
+    int i, number_of_fields;
+    s48_value record = S48_FALSE;
+    s48_value record_type = S48_FALSE;
+    S48_DECLARE_GC_PROTECT(1);
+
+    S48_GC_PROTECT_1(record_type);
+
+    S48_SHARED_BINDING_CHECK(type_shared_binding);
+    S48_SHARED_BINDING_CHECK(the_record_type_binding);
+
+    record_type = S48_SHARED_BINDING_REF(type_shared_binding);
+
+    s48_check_record_type(record_type, the_record_type_binding);
+
+    number_of_fields =
+      S48_UNSAFE_EXTRACT_FIXNUM(S48_RECORD_TYPE_NUMBER_OF_FIELDS(record_type));
+
+    record = s48_allocate_stob(S48_STOBTYPE_RECORD,
+			   (number_of_fields + 1) * sizeof(s48_value));
+
+    S48_UNSAFE_RECORD_SET(record, -1, record_type);
+    for (i = 0; i < number_of_fields; ++i)
+      S48_UNSAFE_RECORD_SET(record, i, S48_UNSPECIFIC);
+
+    S48_GC_UNPROTECT();
+
+    return record;
+}
+
+/*
+ * Raise an exception if `record' is not a record whose type is the one
+ * found in `type_binding'.
+ */
+void
+s48_check_record_type(s48_value record, s48_value type_binding)
+{
+  if (! S48_RECORD_P(S48_SHARED_BINDING_REF(type_binding)))
+    s48_raise_scheme_exception(S48_EXCEPTION_UNBOUND_EXTERNAL_NAME, 1,
+			       S48_SHARED_BINDING_NAME(type_binding));
+
+  if ((! S48_RECORD_P(record)) ||
+      (S48_UNSAFE_SHARED_BINDING_REF(type_binding) !=
+       S48_UNSAFE_RECORD_REF(record, -1)))
+    s48_raise_argtype_error(record);
+}    
+
+long
+s48_length(s48_value list)
+{
+  long i = 0;
+
+  while (!(S48_EQ(list, S48_NULL)))
+    {
+      list = S48_CDR(list);
+      ++i;
+    }
+  return S48_UNSAFE_ENTER_FIXNUM(i);
+}
+
diff --git a/c/fake/dlfcn.h b/c/fake/dlfcn.h
new file mode 100644
index 0000000..2c29be7
--- /dev/null
+++ b/c/fake/dlfcn.h
@@ -0,0 +1,11 @@
+/*
+ * This include file is for systems which do not have dynamic loading.
+ */
+#if ! defined(HAVE_DLOPEN)
+
+extern void	*dlopen(char *filename, int flags);
+extern char	*dlerror(void);
+extern void	*dlsym(void *lib, char *name);
+extern int	dlclose(void *lib);
+
+#endif
diff --git a/c/fake/libdl1.c b/c/fake/libdl1.c
new file mode 100644
index 0000000..753ef06
--- /dev/null
+++ b/c/fake/libdl1.c
@@ -0,0 +1,101 @@
+/*
+ * This is a fake version of the dynamic loading library for machines
+ * which don't have it, but which have nlist.  We fake the stuff so that
+ * looking up in a NULL open library returns symbols in the current executable
+ * (whose name is pointed to by object_file).
+ */
+#include "sysdep.h"
+#include <nlist.h>
+
+#ifdef	USCORE
+#include <string.h>
+#endif
+
+#if	! defined(NLIST_HAS_N_NAME)
+#define	n_name	n_un.n_name
+#endif
+
+
+static char	self[] = "I am the wallrus",
+		*lasterror;
+
+
+char	*
+dlerror(void)
+{
+	char	*res;
+
+	res = lasterror;
+	lasterror = NULL;
+	return (res);
+}
+
+
+void	*
+dlopen(char *name, int flags)
+{
+	if (name == NULL)
+		return ((void *)self);
+	lasterror = "Dynamic loading not supported on this machine";
+	return (NULL);
+}
+
+
+int
+dlclose(void *lib)
+{
+	return (0);
+}
+
+
+void	*
+dlsym(void *lib, char *name)
+{
+	struct nlist	names[2];
+	int		status;
+	extern char	*s48_object_file;
+#ifdef	USCORE
+	int		len;
+	char		*tmp,
+			buff[40];
+#endif
+
+	if (lib != self) {
+		lasterror = "Bad library pointer passed to dlsym()";
+		return (NULL);
+	}
+	if (object_file == NULL) {
+		lasterror = "I don't know the name of my executable";
+		return (NULL);
+	}
+#ifdef	USCORE
+	len = 1 + strlen(name) + 1;
+	if (len <= sizeof(buff))
+		tmp = buff;
+	else {
+		tmp = (char *)malloc(len);
+		if (tmp == NULL) {
+			lasterror = "Out of space";
+			return (NULL);
+		}
+	}
+	tmp[0] = '_';
+	strcpy(tmp + 1, name);
+	name = tmp;
+#endif
+	names[0].n_name = name;
+	names[0].n_value = 0;		/* for Linux */
+	names[0].n_type = 0;		/* for Linux */
+	names[1].n_name = NULL;
+	status = nlist(object_file, names);
+#ifdef	USCORE
+	if (tmp != buff)
+		free((void *)tmp);
+#endif
+	if ((status != 0)
+	||  (names[0].n_value == 0 && names[0].n_type == 0)) {
+		lasterror = "Symbol not found";
+		return (NULL);
+	}
+	return (names[0].n_value);
+}
diff --git a/c/fake/libdl2.c b/c/fake/libdl2.c
new file mode 100644
index 0000000..376ea24
--- /dev/null
+++ b/c/fake/libdl2.c
@@ -0,0 +1,43 @@
+/*
+ * This is a fake version of the dynamic loading library for machines
+ * which don't have it, and don't even have an nlist.
+ * We fake it so that everything fails.
+ */
+#include "sysdep.h"
+
+
+static char	*lasterror;
+
+
+char	*
+dlerror(void)
+{
+	char	*res;
+
+	res = lasterror;
+	lasterror = NULL;
+	return (res);
+}
+
+
+void	*
+dlopen(char *name, int flags)
+{
+	lasterror = "Dynamic loading not supported on this machine";
+	return (NULL);
+}
+
+
+int
+dlclose(void *lib)
+{
+	return (0);
+}
+
+
+void	*
+dlsym(void *lib, char *name)
+{
+	lasterror = "Dynamic loading not supported on this machine";
+	return (NULL);
+}
diff --git a/c/fake/sigact.h b/c/fake/sigact.h
new file mode 100644
index 0000000..e12edcb
--- /dev/null
+++ b/c/fake/sigact.h
@@ -0,0 +1,15 @@
+/*
+ * If we don't have sigaction, we fake it using signal.
+ */
+#if	! defined(HAVE_SIGACTION)
+
+struct	sigaction {
+	void	(*sa_handler)();
+	int	sa_mask;
+	int	sa_flags;
+};
+
+#define	sigaction(sig, act, oact)	signal((sig), (act)->sa_handler)
+#define	sigemptyset(ign)		0
+
+#endif
diff --git a/c/fake/strerror.c b/c/fake/strerror.c
new file mode 100644
index 0000000..fe1ec7e
--- /dev/null
+++ b/c/fake/strerror.c
@@ -0,0 +1,22 @@
+/*
+ * If the system doesn't have a strerror procedure, we provide our own.
+ * Note, this depends on sys_nerr and sys_errlist being provided.
+ * If your system doesn't provide that either, you can replace this
+ * procedure with one that always returns "Unknown error".
+ */
+#include "sysdep.h"
+
+
+extern int	sys_nerr;
+extern char	*sys_errlist[];
+
+
+char	*
+strerror(int errnum)
+{
+	if ((0 <= errnum)
+	&&  (errnum < sys_nerr))
+		return (sys_errlist[errnum]);
+	else
+		return ("Unknown error");
+}
diff --git a/c/fake/strerror.h b/c/fake/strerror.h
new file mode 100644
index 0000000..670e683
--- /dev/null
+++ b/c/fake/strerror.h
@@ -0,0 +1,8 @@
+/*
+ * If we don't have strerror(), we fake it using sys_nerr and sys_errlist.
+ */
+#if	! defined(HAVE_STRERROR)
+
+extern char	*strerror(int errnum);
+
+#endif
diff --git a/c/fake/sys-select.h b/c/fake/sys-select.h
new file mode 100644
index 0000000..d5dc08c
--- /dev/null
+++ b/c/fake/sys-select.h
@@ -0,0 +1,9 @@
+/*
+ * If we have a sys/select.h, then include it.
+ */
+#if	defined(HAVE_SYS_SELECT_H)
+
+#include <sys/types.h>
+#include <sys/select.h>
+
+#endif
diff --git a/c/fd-io.h b/c/fd-io.h
new file mode 100644
index 0000000..19255c0
--- /dev/null
+++ b/c/fd-io.h
@@ -0,0 +1,16 @@
+
+#define STDIN_FD() 0
+#define STDOUT_FD() 1
+#define STDERR_FD() 2
+
+extern int ps_open_fd(char *in_filename, bool is_input, long *status);
+
+extern int ps_close_fd(long fd_as_long);
+
+extern long ps_read_fd(long fd_as_long, char *buf_as_long, long max, bool waitp,
+		       bool *eofp, bool *pending, long *status);
+
+extern long ps_write_fd(long fd_as_long, char *buf_as_long, long max,
+			bool *pending, long *status);
+
+extern long ps_abort_fd_op(long fd_as_long);
diff --git a/c/io.h b/c/io.h
new file mode 100644
index 0000000..8357210
--- /dev/null
+++ b/c/io.h
@@ -0,0 +1,12 @@
+extern FILE	*ps_open_input_file(char *, long *);
+extern FILE	*ps_open_output_file(char *, long *);
+extern long	ps_close(FILE *);
+extern char	ps_read_char(FILE *, char *, long *, char);
+extern long	ps_read_integer(FILE *, char *, long *);
+extern long	ps_write_char(char, FILE *);
+extern long	ps_write_integer(long, FILE *);
+extern long	ps_write_string(char *, FILE *);
+extern long	ps_read_block(FILE *, char *, long, char *, long *);
+extern long	ps_write_block(FILE *, char *, long);
+extern char	*ps_error_string(long);
+extern void	ps_error(char *, long count, ...);
diff --git a/c/main.c b/c/main.c
new file mode 100644
index 0000000..1267c24
--- /dev/null
+++ b/c/main.c
@@ -0,0 +1,181 @@
+/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
+   See file COPYING. */
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <unistd.h>
+#include "scheme48vm.h"
+#include "scheme48heap.h"
+
+#if !defined(DEFAULT_HEAP_SIZE)
+/* 1.5 megacell = 6 megabytes (3 meg per semispace) */
+#define DEFAULT_HEAP_SIZE 1500000L
+#endif
+
+#if !defined(DEFAULT_STACK_SIZE)
+/* 2500 cells = 10000 bytes */
+#define DEFAULT_STACK_SIZE 2500L
+#endif
+
+#if defined(STATIC_AREAS)
+#define DEFAULT_IMAGE_NAME NULL
+#else
+
+/* DEFAULT_IMAGE_NAME should be defined using the -D switch to cc. */
+#if !defined(DEFAULT_IMAGE_NAME)
+#define DEFAULT_IMAGE_NAME "scheme48.image"
+#endif
+
+#endif /* STATIC_AREAS */
+
+extern void	s48_sysdep_init(void);
+extern void	s48_initialize_external_modules(void);
+
+char *s48_object_file;   /* specified via a command line argument */
+char *s48_reloc_file;    /* dynamic loading will set this */
+
+int
+main(argc, argv)
+     int argc; char **argv;
+{
+  char *image_name = DEFAULT_IMAGE_NAME;
+  long heap_size = DEFAULT_HEAP_SIZE;    /* in numbers of cells */
+  long stack_size = DEFAULT_STACK_SIZE;  /* in numbers of cells */
+  int errors = 0;
+  long return_value;
+  void *heap, *stack;
+  long required_heap_size;
+  int warn_undefined_imported_bindings_p = 1;
+
+#if defined(STATIC_AREAS)
+  extern long static_entry;
+  extern long static_symbol_table;
+  extern long static_imported_binding_table, static_exported_binding_table;
+  extern long p_count, *p_areas[], p_sizes[];
+  extern long i_count, *i_areas[], i_sizes[];
+#endif
+
+  long vm_argc = 0;
+  char *me = *argv;		/* Save program name. */
+
+  s48_object_file = s48_reloc_file = NULL;
+
+  argv++; argc--;		/* Skip program name. */
+
+  for (; argc > 0; argc--, argv++)
+    if (argv[0][0] == '-')
+      switch (argv[0][1]) {
+      case 'h':
+	argc--; argv++;
+	if (argc == 0) { errors++; break; }
+	heap_size = atoi(*argv);
+	if (heap_size <= 0) errors++;
+	break;
+      case 's':
+	argc--; argv++;
+	if (argc == 0) { errors++; break; }
+	stack_size = atoi(*argv);
+	if (stack_size <= 0) errors++;
+	break;
+      case 'i':
+	argc--; argv++;
+	if (argc == 0) { errors++; break; }
+	image_name = *argv;
+	break;
+      case 'a':
+	argc--;
+	vm_argc = argc;    /* remaining args are passed to the VM */
+	argc = 0;
+	break;
+      case 'o':
+        argc--; argv++;
+	if (argc == 0) { errors++; break; }
+        s48_object_file = *argv;
+	break;
+      case 'u':
+        argc--; argv++;
+	warn_undefined_imported_bindings_p = 0;
+	break;
+      default:
+	fprintf(stderr, "Invalid argument: %s\n", *argv);
+	errors++;
+      }
+    else
+      if (argv[0][0] != '\0') {
+	fprintf(stderr, "Invalid argument: %s\n", *argv);
+	errors++; }
+  if (errors != 0) {
+    fprintf(stderr,
+"Usage: %s [options] [-a arguments]\n\
+Options: -h <total heap size in words>\n\
+	 -s <stack buffer size in words>\n\
+         -i <image file name>\n\
+         -o <object file name>\n\
+         -u [don't warn on unbound external identifiers]",
+	    me);
+    return 1;
+  }
+
+  s48_sysdep_init();
+  s48_heap_init();
+  s48_init();
+
+  if (image_name == NULL)
+    required_heap_size = 0;
+  else {
+    /* check_image_header returns number of bytes; required_heap_size
+       is number of cells. */
+    required_heap_size =
+      s48_check_image_header((unsigned char *)image_name) >> 2;
+    if (-1 == required_heap_size) {
+      fprintf(stderr, "Image file \"%s\" is unusable.\n", image_name);
+      return 1; }
+  }
+
+  /* two semi-spaces, plus we want some room to maneuver */
+  if (heap_size < 4 * required_heap_size) {
+    fprintf(stderr, "heap size %ld is too small, using %ld\n",
+	    heap_size, 4 * required_heap_size);
+    heap_size = 4 * required_heap_size; }
+
+  heap = (void *) malloc(heap_size * sizeof(long));
+  stack = (void *) malloc(stack_size * sizeof(long));
+    
+  if (!heap || !stack) {
+    fprintf(stderr, "system is out of memory\n");
+    return 1; }
+
+  s48_initialize_heap((long)heap, heap_size);
+
+#if defined(STATIC_AREAS)
+  if (image_name == NULL) {
+    s48_register_static_areas(p_count, p_areas, p_sizes,
+			      i_count, i_areas, i_sizes);
+    s48_set_image_valuesB(static_entry,
+			  static_symbol_table,
+			  static_imported_binding_table,
+			  static_exported_binding_table);
+  } else if (s48_read_image() == -1) {
+    fprintf(stderr, "Image file \"%s\" is unusable.\n", image_name);
+    return 1; }
+#else
+  if (s48_read_image() == -1) {
+    fprintf(stderr, "Image file \"%s\" is unusable.\n", image_name);
+    return 1; }
+#endif
+
+  s48_initialize_vm(stack, stack_size);
+
+  s48_initialize_external_modules();
+  
+  if (warn_undefined_imported_bindings_p)
+    s48_warn_about_undefined_imported_bindings();
+  
+  return_value = s48_call_startup_procedure(argv, vm_argc);
+
+  if (s48_reloc_file != NULL)
+    if (0 != unlink(s48_reloc_file))
+      fprintf(stderr, "unable to delete file %s\n", s48_reloc_file);
+
+  return(return_value);
+}
diff --git a/c/old-scheme48.h b/c/old-scheme48.h
new file mode 100644
index 0000000..03f5d10
--- /dev/null
+++ b/c/old-scheme48.h
@@ -0,0 +1,110 @@
+typedef long scheme_value;
+
+#define FIXNUM_TAG 0
+#define FIXNUMP(x) (((long)(x) & 3L) == FIXNUM_TAG)
+#define IMMEDIATE_TAG 1
+#define IMMEDIATEP(x) (((long)(x) & 3L) == IMMEDIATE_TAG)
+#define HEADER_TAG 2
+#define HEADERP(x) (((long)(x) & 3L) == HEADER_TAG)
+#define STOB_TAG 3
+#define STOBP(x) (((long)(x) & 3L) == STOB_TAG)
+
+#define ENTER_FIXNUM(n)   ((scheme_value)((n) << 2))
+#define EXTRACT_FIXNUM(x) ((long)(x) >> 2)
+
+#define MISC_IMMEDIATE(n) (scheme_value)(IMMEDIATE_TAG | ((n) << 2))
+#define SCHFALSE    MISC_IMMEDIATE(0)
+#define SCHTRUE    MISC_IMMEDIATE(1)
+#define SCHCHAR    MISC_IMMEDIATE(2)
+#define SCHUNSPECIFIC    MISC_IMMEDIATE(3)
+#define SCHUNDEFINED    MISC_IMMEDIATE(4)
+#define SCHEOF    MISC_IMMEDIATE(5)
+#define SCHNULL    MISC_IMMEDIATE(6)
+#define UNDEFINED SCHUNDEFINED
+#define UNSPECIFIC SCHUNSPECIFIC
+
+#define ENTER_BOOLEAN(n) ((n) ? SCHTRUE : SCHFALSE)
+#define EXTRACT_BOOLEAN(x) ((x) != SCHFALSE)
+
+#define ENTER_CHAR(c) (SCHCHAR | ((c) << 8))
+#define EXTRACT_CHAR(x) ((x) >> 8)
+#define CHARP(x) ((((long) (x)) & 0xff) == SCHCHAR)
+
+#define ADDRESS_AFTER_HEADER(x, type) ((type *)((x) - STOB_TAG))
+#define STOB_REF(x, i) ((ADDRESS_AFTER_HEADER(x, long))[i])
+#define STOB_TYPE(x)   ((STOB_HEADER(x)>>2)&31)
+#define STOB_HEADER(x) (STOB_REF((x),-1))
+#define STOB_BLENGTH(x) (STOB_HEADER(x) >> 8)
+#define STOB_LLENGTH(x) (STOB_HEADER(x) >> 10)
+
+#define STOBTYPE_PAIR 0
+#define PAIRP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_PAIR))
+#define STOBTYPE_SYMBOL 1
+#define SYMBOLP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_SYMBOL))
+#define STOBTYPE_VECTOR 2
+#define VECTORP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_VECTOR))
+#define STOBTYPE_CLOSURE 3
+#define CLOSUREP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_CLOSURE))
+#define STOBTYPE_LOCATION 4
+#define LOCATIONP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_LOCATION))
+#define STOBTYPE_CHANNEL 5
+#define CHANNELP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_CHANNEL))
+#define STOBTYPE_PORT 6
+#define PORTP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_PORT))
+#define STOBTYPE_RATNUM 7
+#define RATNUMP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_RATNUM))
+#define STOBTYPE_RECORD 8
+#define RECORDP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_RECORD))
+#define STOBTYPE_CONTINUATION 9
+#define CONTINUATIONP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_CONTINUATION))
+#define STOBTYPE_EXTENDED_NUMBER 10
+#define EXTENDED_NUMBERP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_EXTENDED_NUMBER))
+#define STOBTYPE_TEMPLATE 11
+#define TEMPLATEP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_TEMPLATE))
+#define STOBTYPE_WEAK_POINTER 12
+#define WEAK_POINTERP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_WEAK_POINTER))
+#define STOBTYPE_SHARED_BINDING 13
+#define SHARED_BINDINGP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_SHARED_BINDING))
+#define STOBTYPE_UNUSED_D_HEADER1 14
+#define UNUSED_D_HEADER1P(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_UNUSED_D_HEADER1))
+#define STOBTYPE_UNUSED_D_HEADER2 15
+#define UNUSED_D_HEADER2P(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_UNUSED_D_HEADER2))
+#define STOBTYPE_STRING 16
+#define STRINGP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_STRING))
+#define STOBTYPE_CODE_VECTOR 17
+#define CODE_VECTORP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_CODE_VECTOR))
+#define STOBTYPE_DOUBLE 18
+#define DOUBLEP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_DOUBLE))
+#define STOBTYPE_BIGNUM 19
+#define BIGNUMP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_BIGNUM))
+
+#define CAR(x) STOB_REF(x, 0)
+#define CDR(x) STOB_REF(x, 1)
+#define SYMBOL_TO_STRING(x) STOB_REF(x, 0)
+#define LOCATION_ID(x) STOB_REF(x, 0)
+#define CONTENTS(x) STOB_REF(x, 1)
+#define CLOSURE_TEMPLATE(x) STOB_REF(x, 0)
+#define CLOSURE_ENV(x) STOB_REF(x, 1)
+#define WEAK_POINTER_REF(x) STOB_REF(x, 0)
+#define SHARED_BINDING_NAME(x) STOB_REF(x, 0)
+#define SHARED_BINDING_IS_IMPORTP(x) STOB_REF(x, 1)
+#define SHARED_BINDING_REF(x) STOB_REF(x, 2)
+#define PORT_HANDLER(x) STOB_REF(x, 0)
+#define PORT_STATUS(x) STOB_REF(x, 1)
+#define PORT_LOCK(x) STOB_REF(x, 2)
+#define PORT_LOCKEDP(x) STOB_REF(x, 3)
+#define PORT_DATA(x) STOB_REF(x, 4)
+#define PORT_BUFFER(x) STOB_REF(x, 5)
+#define PORT_INDEX(x) STOB_REF(x, 6)
+#define PORT_LIMIT(x) STOB_REF(x, 7)
+#define PORT_PENDING_EOFP(x) STOB_REF(x, 8)
+#define CHANNEL_STATUS(x) STOB_REF(x, 0)
+#define CHANNEL_ID(x) STOB_REF(x, 1)
+#define CHANNEL_OS_INDEX(x) STOB_REF(x, 2)
+
+#define VECTOR_LENGTH(x) STOB_LLENGTH(x)
+#define VECTOR_REF(x, i) STOB_REF(x, i)
+#define CODE_VECTOR_LENGTH(x)  STOB_BLENGTH(x)
+#define CODE_VECTOR_REF(x, i)  (ADDRESS_AFTER_HEADER(x, unsigned char)[i])
+#define STRING_LENGTH(x)  (STOB_BLENGTH(x)-1)
+#define STRING_REF(x, i)  (ADDRESS_AFTER_HEADER(x, char)[i])
diff --git a/c/prescheme.h b/c/prescheme.h
new file mode 100644
index 0000000..b95d022
--- /dev/null
+++ b/c/prescheme.h
@@ -0,0 +1,59 @@
+#include <errno.h>
+#include "io.h"
+
+#define PS_READ_CHAR(PORT,RESULT,EOFP,STATUS)		\
+{							\
+  FILE * TTport = PORT;					\
+  int TTchar;						\
+  if (EOF == (TTchar = getc(TTport)))			\
+    RESULT = ps_read_char(TTport, &EOFP, &STATUS, 0==1);\
+  else {						\
+    RESULT = TTchar; 					\
+    EOFP = 0;						\
+    STATUS = 0; }					\
+}
+
+#define PS_PEEK_CHAR(PORT,RESULT,EOFP,STATUS)		\
+{							\
+  FILE * TTport = PORT;					\
+  int TTchar;						\
+  if (EOF == (TTchar = getc(TTport)))			\
+    RESULT = ps_read_char(TTport, &EOFP, &STATUS, 0==0);\
+  else {						\
+    RESULT = TTchar; 					\
+    ungetc(RESULT, TTport);				\
+    EOFP = 0;						\
+    STATUS = 0; }					\
+}
+
+#define PS_READ_INTEGER(PORT,RESULT,EOFP,STATUS)	\
+RESULT = ps_read_integer(PORT,&EOFP,&STATUS);
+
+#define PS_WRITE_CHAR(CHAR,PORT,STATUS)			\
+{							\
+  FILE * TTport = PORT;					\
+  char TTchar = CHAR;					\
+  if (EOF == putc(TTchar,TTport))			\
+    STATUS = ps_write_char(TTchar,TTport);		\
+  else {						\
+    STATUS = 0; }					\
+}
+
+
+/* C shifts may not work if the amount is greater than the machine word size */
+/* Patched by JAR 6/6/93 */
+
+#define PS_SHIFT_RIGHT(X,Y,RESULT)   \
+{                                    \
+  long TTx = X,  TTy = Y;            \
+  RESULT = TTy >= 32 ? (TTx < 0 ? -1 : 0) : TTx >> TTy; \
+}  
+
+#define PS_SHIFT_LEFT(X,Y,RESULT)    \
+{                                    \
+  long TTy = Y;                      \
+  RESULT = TTy >= 32 ? 0 : X << TTy; \
+}  
+
+extern long s48_return_value, s48_run_machine();
+
diff --git a/c/scheme48.h b/c/scheme48.h
new file mode 100644
index 0000000..55b843a
--- /dev/null
+++ b/c/scheme48.h
@@ -0,0 +1,459 @@
+/* This file was generated automatically.
+   It's probably not a good idea to change it. */
+
+#ifndef _H_SCHEME48
+#define _H_SCHEME48
+
+/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
+   See file COPYING. */
+
+#include "write-barrier.h"
+
+typedef long	s48_value;
+
+#define NO_ERRORS 0    /* errno value */
+
+/* Misc stuff */
+
+#define S48_EQ(v1, v2) ((v1) == (v2))
+
+#define S48_MAX_FIXNUM_VALUE ((1 << 29) - 1)
+#define S48_MIN_FIXNUM_VALUE (-1 << 29)
+
+extern int		s48_stob_has_type(s48_value, int);
+extern long		s48_stob_length(s48_value, int);
+extern long		s48_stob_byte_length(s48_value, int);
+extern s48_value	s48_stob_ref(s48_value, int, long);
+extern void		s48_stob_set(s48_value, int, long, s48_value);
+extern char		s48_stob_byte_ref(s48_value, int, long);
+extern void		s48_stob_byte_set(s48_value, int, long, char);
+
+extern void		s48_register_gc_rootB(char *);
+extern void		s48_push_gc_rootsB(char *, long);
+extern char		s48_pop_gc_rootsB(void);
+extern char		s48_pop_gc_roots_up_to_markerB(char *);
+
+extern s48_value	s48_enter_char(unsigned char);
+extern unsigned char	s48_extract_char(s48_value);
+extern s48_value	s48_enter_fixnum(long);
+extern long		s48_extract_fixnum(s48_value);
+extern s48_value	s48_enter_integer(long);
+extern long		s48_extract_integer(s48_value);
+extern s48_value	s48_enter_double(double);
+extern double		s48_extract_double(s48_value);
+extern s48_value	s48_cons(s48_value, s48_value);
+extern s48_value	s48_enter_string(char *);
+extern char *		s48_extract_string(s48_value);
+extern s48_value	s48_enter_substring(char *, int);
+extern s48_value	s48_make_string(int, char);
+extern s48_value	s48_make_vector(int, s48_value);
+extern s48_value	s48_make_byte_vector(int);
+extern s48_value	s48_make_record(s48_value);
+extern s48_value	s48_make_weak_pointer(s48_value);
+extern void		s48_check_record_type(s48_value, s48_value);
+extern long		s48_length(s48_value);
+extern s48_value	s48_enter_pointer(void *);
+extern s48_value	s48_get_imported_binding(char *);
+extern void		s48_define_exported_binding(char *, s48_value);
+
+extern s48_value	s48_set_channel_os_index(s48_value, long);
+extern s48_value	s48_add_channel(s48_value, s48_value, long);
+extern void		s48_close_channel(long);
+
+extern s48_value	s48_call_scheme(s48_value proc, long nargs, ...);
+
+#define S48_EXPORT_FUNCTION(p) (s48_define_exported_binding(#p, s48_enter_pointer(p)))
+
+#define S48_MAKE_VALUE(type) (s48_make_byte_vector(sizeof(type)))
+extern void *		s48_value_pointer(s48_value);
+
+#define S48_EXTRACT_VALUE_POINTER(x, type) ((type *) s48_value_pointer(x))
+#define S48_EXTRACT_VALUE(x, type) (*(S48_EXTRACT_VALUE_POINTER((x), type)))
+#define S48_SET_VALUE(x, type, v) (S48_EXTRACT_VALUE((x), type) = (v))
+
+#define S48_UNSAFE_EXTRACT_VALUE_POINTER(x, type)		\
+  (S48_ADDRESS_AFTER_HEADER((x), type))
+#define S48_UNSAFE_EXTRACT_VALUE(x, type)			\
+  (*(S48_UNSAFE_EXTRACT_VALUE_POINTER((x), type)))
+#define S48_UNSAFE_SET_VALUE(x, type, v)			\
+  (S48_UNSAFE_EXTRACT_VALUE((x), type) = (v))
+
+#define S48_UNSAFE_EXTRACT_DOUBLE(x)				\
+  (*(S48_ADDRESS_AFTER_HEADER((x), double)))
+
+#define S48_DECLARE_GC_PROTECT(n) long ___gc_buffer[(n)+2]
+
+#define S48_GC_PROTECT_1(v) \
+  (___gc_buffer[2]=(long)&(v), \
+   s48_push_gc_rootsB((char *) ___gc_buffer, 1))
+
+#define S48_GC_PROTECT_2(v1, v2) \
+  (___gc_buffer[2]=(long)&(v1), ___gc_buffer[3]=(long)&(v2), \
+   s48_push_gc_rootsB((char *) ___gc_buffer, 2))
+
+#define S48_GC_PROTECT_3(v1, v2, v3) \
+  (___gc_buffer[2]=(long)&(v1), \
+   ___gc_buffer[3]=(long)&(v2), \
+   ___gc_buffer[4]=(long)&(v3), \
+   s48_push_gc_rootsB((char *) ___gc_buffer, 3))
+
+#define S48_GC_PROTECT_4(v1, v2, v3, v4) \
+  (___gc_buffer[2]=(long)&(v1), \
+   ___gc_buffer[3]=(long)&(v2), \
+   ___gc_buffer[4]=(long)&(v3), \
+   ___gc_buffer[5]=(long)&(v4), \
+   s48_push_gc_rootsB((char *) ___gc_buffer, 4))
+
+#define S48_GC_PROTECT_5(v1, v2, v3, v4, v5) \
+  (___gc_buffer[2]=(long)&(v1), \
+   ___gc_buffer[3]=(long)&(v2), \
+   ___gc_buffer[4]=(long)&(v3), \
+   ___gc_buffer[5]=(long)&(v4), \
+   ___gc_buffer[6]=(long)&(v5), \
+   s48_push_gc_rootsB((char *) ___gc_buffer, 5))
+
+#define S48_GC_PROTECT_6(v1, v2, v3, v4, v5, v6) \
+  (___gc_buffer[2]=(long)&(v1), \
+   ___gc_buffer[3]=(long)&(v2), \
+   ___gc_buffer[4]=(long)&(v3), \
+   ___gc_buffer[5]=(long)&(v4), \
+   ___gc_buffer[6]=(long)&(v5), \
+   ___gc_buffer[7]=(long)&(v6), \
+   s48_push_gc_rootsB((char *) ___gc_buffer, 6))
+
+#define S48_GC_PROTECT_7(v1, v2, v3, v4, v5, v6, v7) \
+  (___gc_buffer[2]=(long)&(v1), \
+   ___gc_buffer[3]=(long)&(v2), \
+   ___gc_buffer[4]=(long)&(v3), \
+   ___gc_buffer[5]=(long)&(v4), \
+   ___gc_buffer[6]=(long)&(v5), \
+   ___gc_buffer[7]=(long)&(v6), \
+   ___gc_buffer[8]=(long)&(v7), \
+   s48_push_gc_rootsB((char *) ___gc_buffer, 7))
+
+#define S48_GC_PROTECT_8(v1, v2, v3, v4, v5, v6, v7, v8) \
+  (___gc_buffer[2]=(long)&(v1), \
+   ___gc_buffer[3]=(long)&(v2), \
+   ___gc_buffer[4]=(long)&(v3), \
+   ___gc_buffer[5]=(long)&(v4), \
+   ___gc_buffer[6]=(long)&(v5), \
+   ___gc_buffer[7]=(long)&(v6), \
+   ___gc_buffer[8]=(long)&(v7), \
+   ___gc_buffer[9]=(long)&(v8), \
+   s48_push_gc_rootsB((char *) ___gc_buffer, 8))
+
+#define S48_GC_PROTECT_9(v1, v2, v3, v4, v5, v6, v7, v8, v9) \
+  (___gc_buffer[2]=(long)&(v1), \
+   ___gc_buffer[3]=(long)&(v2), \
+   ___gc_buffer[4]=(long)&(v3), \
+   ___gc_buffer[5]=(long)&(v4), \
+   ___gc_buffer[6]=(long)&(v5), \
+   ___gc_buffer[7]=(long)&(v6), \
+   ___gc_buffer[8]=(long)&(v7), \
+   ___gc_buffer[9]=(long)&(v8), \
+   ___gc_buffer[10]=(long)&(v9), \
+   s48_push_gc_rootsB((char *) ___gc_buffer, 9))
+
+#define S48_GC_PROTECT_10(v1, v2, v3, v4, v5, v6, v7, v8, v9, v10) \
+  (___gc_buffer[2]=(long)&(v1), \
+   ___gc_buffer[3]=(long)&(v2), \
+   ___gc_buffer[4]=(long)&(v3), \
+   ___gc_buffer[5]=(long)&(v4), \
+   ___gc_buffer[6]=(long)&(v5), \
+   ___gc_buffer[7]=(long)&(v6), \
+   ___gc_buffer[8]=(long)&(v7), \
+   ___gc_buffer[9]=(long)&(v8), \
+   ___gc_buffer[10]=(long)&(v9), \
+   ___gc_buffer[11]=(long)&(v10), \
+   s48_push_gc_rootsB((char *) ___gc_buffer, 10))
+
+#define S48_GC_UNPROTECT()				\
+   do { if (! s48_pop_gc_rootsB())			\
+       	  s48_raise_scheme_exception( S48_EXCEPTION_GC_PROTECTION_MISMATCH, 0); \
+      } while(0)
+
+#define S48_GC_PROTECT_GLOBAL(v) (s48_register_gc_rootB((char *)&(v)))
+
+/* Exceptions */
+
+extern void s48_raise_scheme_exception(long type, long nargs, ...);
+extern void s48_raise_argtype_error(s48_value value);
+extern void s48_raise_argnumber_error(s48_value value,
+				  s48_value min, s48_value max);
+extern void s48_raise_range_error(s48_value value,
+			      s48_value min, s48_value max);
+extern void s48_raise_closed_channel_error();
+extern void s48_raise_os_error(int the_errno);
+extern void s48_raise_string_os_error(char *reason);
+extern void s48_raise_out_of_memory_error();
+
+/* Type checking */
+
+#define S48_CHECK_PAIR(v) do { if (!S48_PAIR_P(v)) s48_raise_argtype_error(v); } while (0)
+#define S48_CHECK_FIXNUM(v) do { if (!S48_FIXNUM_P(v)) s48_raise_argtype_error(v); } while (0)
+#define S48_CHECK_STRING(v) do { if (!S48_STRING_P(v)) s48_raise_argtype_error(v); } while (0)
+#define S48_CHECK_CHANNEL(v) do { if (!S48_CHANNEL_P(v)) s48_raise_argtype_error(v); } while (0)
+#define S48_CHECK_RECORD(v) do { if (!S48_RECORD_P(v)) s48_raise_argtype_error(v); } while (0)
+#define S48_CHECK_VALUE(v) do { if (!S48_BYTE_VECTOR_P(v)) s48_raise_argtype_error(v); } while (0)
+#define S48_CHECK_EXPORT_BINDING(v) do { if (!S48_EXPORT_BINDING_P(v)) s48_raise_argtype_error(v); } while (0)
+
+#define S48_VALUE_P(v) (S48_BYTE_VECTOR_P(v))
+
+extern void s48_check_record_type(s48_value record, s48_value type_binding);
+
+#define S48_SHARED_BINDING_CHECK(binding)					\
+  do { if (S48_UNSPECIFIC == S48_SHARED_BINDING_REF(binding))		\
+         s48_raise_scheme_exception(S48_EXCEPTION_UNBOUND_EXTERNAL_NAME, 1,	\
+				    S48_SHARED_BINDING_NAME(binding));	\
+  } while(0)
+
+#define S48_FIXNUM_TAG 0
+#define S48_FIXNUM_P(x) (((long)(x) & 3L) == S48_FIXNUM_TAG)
+#define S48_IMMEDIATE_TAG 1
+#define S48_IMMEDIATE_P(x) (((long)(x) & 3L) == S48_IMMEDIATE_TAG)
+#define S48_HEADER_TAG 2
+#define S48_HEADER_P(x) (((long)(x) & 3L) == S48_HEADER_TAG)
+#define S48_STOB_TAG 3
+#define S48_STOB_P(x) (((long)(x) & 3L) == S48_STOB_TAG)
+
+#define S48_UNSAFE_ENTER_FIXNUM(n)   ((s48_value)((n) << 2))
+#define S48_UNSAFE_EXTRACT_FIXNUM(x) ((long)(x) >> 2)
+
+#define S48_MISC_IMMEDIATE(n) ((s48_value)(S48_IMMEDIATE_TAG | ((n) << 2)))
+#define S48_FALSE    (S48_MISC_IMMEDIATE(0))
+#define S48_TRUE    (S48_MISC_IMMEDIATE(1))
+#define S48_CHAR    (S48_MISC_IMMEDIATE(2))
+#define S48_UNSPECIFIC    (S48_MISC_IMMEDIATE(3))
+#define S48_UNDEFINED    (S48_MISC_IMMEDIATE(4))
+#define S48_EOF    (S48_MISC_IMMEDIATE(5))
+#define S48_NULL    (S48_MISC_IMMEDIATE(6))
+
+#define S48_ENTER_BOOLEAN(n) ((n) ? S48_TRUE : S48_FALSE)
+#define S48_EXTRACT_BOOLEAN(x) ((x) != S48_FALSE)
+
+#define S48_UNSAFE_ENTER_CHAR(c) (S48_CHAR | ((c) << 8))
+#define S48_UNSAFE_EXTRACT_CHAR(x) ((x) >> 8)
+#define S48_CHAR_P(x) ((((long) (x)) & 0xff) == S48_CHAR)
+
+#define S48_ADDRESS_AFTER_HEADER(x, type) ((type *)((x) - S48_STOB_TAG))
+#define S48_STOB_REF(x, i) (S48_ADDRESS_AFTER_HEADER(x, s48_value)[i])
+#define S48_STOB_BYTE_REF(x, i) (((char *)S48_ADDRESS_AFTER_HEADER(x, s48_value))[i])
+#define S48_STOB_SET(x, i, v) do { s48_value __stob_set_x = (x); long __stob_set_i = (i); s48_value __stob_set_v = (v); if (S48_STOB_IMMUTABLEP(__stob_set_x)) s48_raise_argtype_error(__stob_set_x); else { S48_WRITE_BARRIER((__stob_set_x), (char *) (&S48_STOB_REF((__stob_set_x), (__stob_set_i))),(__stob_set_v)); *(&S48_STOB_REF((__stob_set_x), (__stob_set_i))) = (__stob_set_v); } } while (0)
+#define S48_STOB_BYTE_SET(x, i, v) do { char __stob_set_x = (x); long __stob_set_i = (i); s48_value __stob_set_v = (v); if (S48_STOB_IMMUTABLEP(__stob_set_x)) s48_raise_argtype_error(__stob_set_x); else *(&S48_STOB_BYTE_REF((__stob_set_x), (__stob_set_i))) = (__stob_set_v); } while (0)
+#define S48_STOB_TYPE(x)   ((S48_STOB_HEADER(x)>>2)&31)
+#define S48_STOB_HEADER(x) (S48_STOB_REF((x),-1))
+#define S48_STOB_ADDRESS(x) (&(S48_STOB_HEADER(x)))
+#define S48_STOB_BYTE_LENGTH(x) (S48_STOB_HEADER(x) >> 8)
+#define S48_STOB_DESCRIPTOR_LENGTH(x) (S48_STOB_HEADER(x) >> 10)
+#define S48_STOB_IMMUTABLEP(x) ((S48_STOB_HEADER(x)>>7) & 1)
+#define S48_STOB_MAKE_IMMUTABLE(x) ((S48_STOB_HEADER(x)) |= (1<<7))
+
+#define S48_STOBTYPE_PAIR 0
+#define S48_PAIR_P(x) (s48_stob_has_type(x, 0))
+#define S48_STOBTYPE_SYMBOL 1
+#define S48_SYMBOL_P(x) (s48_stob_has_type(x, 1))
+#define S48_STOBTYPE_VECTOR 2
+#define S48_VECTOR_P(x) (s48_stob_has_type(x, 2))
+#define S48_STOBTYPE_CLOSURE 3
+#define S48_CLOSURE_P(x) (s48_stob_has_type(x, 3))
+#define S48_STOBTYPE_LOCATION 4
+#define S48_LOCATION_P(x) (s48_stob_has_type(x, 4))
+#define S48_STOBTYPE_CHANNEL 5
+#define S48_CHANNEL_P(x) (s48_stob_has_type(x, 5))
+#define S48_STOBTYPE_PORT 6
+#define S48_PORT_P(x) (s48_stob_has_type(x, 6))
+#define S48_STOBTYPE_RATNUM 7
+#define S48_RATNUM_P(x) (s48_stob_has_type(x, 7))
+#define S48_STOBTYPE_RECORD 8
+#define S48_RECORD_P(x) (s48_stob_has_type(x, 8))
+#define S48_STOBTYPE_CONTINUATION 9
+#define S48_CONTINUATION_P(x) (s48_stob_has_type(x, 9))
+#define S48_STOBTYPE_EXTENDED_NUMBER 10
+#define S48_EXTENDED_NUMBER_P(x) (s48_stob_has_type(x, 10))
+#define S48_STOBTYPE_TEMPLATE 11
+#define S48_TEMPLATE_P(x) (s48_stob_has_type(x, 11))
+#define S48_STOBTYPE_WEAK_POINTER 12
+#define S48_WEAK_POINTER_P(x) (s48_stob_has_type(x, 12))
+#define S48_STOBTYPE_SHARED_BINDING 13
+#define S48_SHARED_BINDING_P(x) (s48_stob_has_type(x, 13))
+#define S48_STOBTYPE_UNUSED_D_HEADER1 14
+#define S48_UNUSED_D_HEADER1_P(x) (s48_stob_has_type(x, 14))
+#define S48_STOBTYPE_UNUSED_D_HEADER2 15
+#define S48_UNUSED_D_HEADER2_P(x) (s48_stob_has_type(x, 15))
+#define S48_STOBTYPE_STRING 16
+#define S48_STRING_P(x) (s48_stob_has_type(x, 16))
+#define S48_STOBTYPE_BYTE_VECTOR 17
+#define S48_BYTE_VECTOR_P(x) (s48_stob_has_type(x, 17))
+#define S48_STOBTYPE_DOUBLE 18
+#define S48_DOUBLE_P(x) (s48_stob_has_type(x, 18))
+#define S48_STOBTYPE_BIGNUM 19
+#define S48_BIGNUM_P(x) (s48_stob_has_type(x, 19))
+
+#define S48_CAR_OFFSET 0
+#define S48_CAR(x) (s48_stob_ref((x), S48_STOBTYPE_PAIR, 0))
+#define S48_UNSAFE_CAR(x) (S48_STOB_REF((x), 0))
+#define S48_SET_CAR(x, v) (s48_stob_ref((x), S48_STOBTYPE_PAIR, 0, (v)))
+#define S48_UNSAFE_SET_CAR(x, v) S48_STOB_SET((x), 0, (v))
+#define S48_CDR_OFFSET 1
+#define S48_CDR(x) (s48_stob_ref((x), S48_STOBTYPE_PAIR, 1))
+#define S48_UNSAFE_CDR(x) (S48_STOB_REF((x), 1))
+#define S48_SET_CDR(x, v) (s48_stob_ref((x), S48_STOBTYPE_PAIR, 1, (v)))
+#define S48_UNSAFE_SET_CDR(x, v) S48_STOB_SET((x), 1, (v))
+#define S48_SYMBOL_TO_STRING_OFFSET 0
+#define S48_SYMBOL_TO_STRING(x) (s48_stob_ref((x), S48_STOBTYPE_SYMBOL, 0))
+#define S48_UNSAFE_SYMBOL_TO_STRING(x) (S48_STOB_REF((x), 0))
+#define S48_LOCATION_ID_OFFSET 0
+#define S48_LOCATION_ID(x) (s48_stob_ref((x), S48_STOBTYPE_LOCATION, 0))
+#define S48_UNSAFE_LOCATION_ID(x) (S48_STOB_REF((x), 0))
+#define S48_SET_LOCATION_ID(x, v) (s48_stob_ref((x), S48_STOBTYPE_LOCATION, 0, (v)))
+#define S48_UNSAFE_SET_LOCATION_ID(x, v) S48_STOB_SET((x), 0, (v))
+#define S48_CONTENTS_OFFSET 1
+#define S48_CONTENTS(x) (s48_stob_ref((x), S48_STOBTYPE_LOCATION, 1))
+#define S48_UNSAFE_CONTENTS(x) (S48_STOB_REF((x), 1))
+#define S48_SET_CONTENTS(x, v) (s48_stob_ref((x), S48_STOBTYPE_LOCATION, 1, (v)))
+#define S48_UNSAFE_SET_CONTENTS(x, v) S48_STOB_SET((x), 1, (v))
+#define S48_CLOSURE_TEMPLATE_OFFSET 0
+#define S48_CLOSURE_TEMPLATE(x) (s48_stob_ref((x), S48_STOBTYPE_CLOSURE, 0))
+#define S48_UNSAFE_CLOSURE_TEMPLATE(x) (S48_STOB_REF((x), 0))
+#define S48_CLOSURE_ENV_OFFSET 1
+#define S48_CLOSURE_ENV(x) (s48_stob_ref((x), S48_STOBTYPE_CLOSURE, 1))
+#define S48_UNSAFE_CLOSURE_ENV(x) (S48_STOB_REF((x), 1))
+#define S48_WEAK_POINTER_REF_OFFSET 0
+#define S48_WEAK_POINTER_REF(x) (s48_stob_ref((x), S48_STOBTYPE_WEAK_POINTER, 0))
+#define S48_UNSAFE_WEAK_POINTER_REF(x) (S48_STOB_REF((x), 0))
+#define S48_SHARED_BINDING_NAME_OFFSET 0
+#define S48_SHARED_BINDING_NAME(x) (s48_stob_ref((x), S48_STOBTYPE_SHARED_BINDING, 0))
+#define S48_UNSAFE_SHARED_BINDING_NAME(x) (S48_STOB_REF((x), 0))
+#define S48_SHARED_BINDING_IS_IMPORTP_OFFSET 1
+#define S48_SHARED_BINDING_IS_IMPORTP(x) (s48_stob_ref((x), S48_STOBTYPE_SHARED_BINDING, 1))
+#define S48_UNSAFE_SHARED_BINDING_IS_IMPORTP(x) (S48_STOB_REF((x), 1))
+#define S48_SHARED_BINDING_REF_OFFSET 2
+#define S48_SHARED_BINDING_REF(x) (s48_stob_ref((x), S48_STOBTYPE_SHARED_BINDING, 2))
+#define S48_UNSAFE_SHARED_BINDING_REF(x) (S48_STOB_REF((x), 2))
+#define S48_SHARED_BINDING_SET(x, v) (s48_stob_ref((x), S48_STOBTYPE_SHARED_BINDING, 2, (v)))
+#define S48_UNSAFE_SHARED_BINDING_SET(x, v) S48_STOB_SET((x), 2, (v))
+#define S48_PORT_HANDLER_OFFSET 0
+#define S48_PORT_HANDLER(x) (s48_stob_ref((x), S48_STOBTYPE_PORT, 0))
+#define S48_UNSAFE_PORT_HANDLER(x) (S48_STOB_REF((x), 0))
+#define S48_PORT_STATUS_OFFSET 1
+#define S48_PORT_STATUS(x) (s48_stob_ref((x), S48_STOBTYPE_PORT, 1))
+#define S48_UNSAFE_PORT_STATUS(x) (S48_STOB_REF((x), 1))
+#define S48_SET_PORT_STATUS(x, v) (s48_stob_ref((x), S48_STOBTYPE_PORT, 1, (v)))
+#define S48_UNSAFE_SET_PORT_STATUS(x, v) S48_STOB_SET((x), 1, (v))
+#define S48_PORT_LOCK_OFFSET 2
+#define S48_PORT_LOCK(x) (s48_stob_ref((x), S48_STOBTYPE_PORT, 2))
+#define S48_UNSAFE_PORT_LOCK(x) (S48_STOB_REF((x), 2))
+#define S48_SET_PORT_LOCK(x, v) (s48_stob_ref((x), S48_STOBTYPE_PORT, 2, (v)))
+#define S48_UNSAFE_SET_PORT_LOCK(x, v) S48_STOB_SET((x), 2, (v))
+#define S48_PORT_LOCKEDP_OFFSET 3
+#define S48_PORT_LOCKEDP(x) (s48_stob_ref((x), S48_STOBTYPE_PORT, 3))
+#define S48_UNSAFE_PORT_LOCKEDP(x) (S48_STOB_REF((x), 3))
+#define S48_SET_PORT_LOCKEDP(x, v) (s48_stob_ref((x), S48_STOBTYPE_PORT, 3, (v)))
+#define S48_UNSAFE_SET_PORT_LOCKEDP(x, v) S48_STOB_SET((x), 3, (v))
+#define S48_PORT_DATA_OFFSET 4
+#define S48_PORT_DATA(x) (s48_stob_ref((x), S48_STOBTYPE_PORT, 4))
+#define S48_UNSAFE_PORT_DATA(x) (S48_STOB_REF((x), 4))
+#define S48_SET_PORT_DATA(x, v) (s48_stob_ref((x), S48_STOBTYPE_PORT, 4, (v)))
+#define S48_UNSAFE_SET_PORT_DATA(x, v) S48_STOB_SET((x), 4, (v))
+#define S48_PORT_BUFFER_OFFSET 5
+#define S48_PORT_BUFFER(x) (s48_stob_ref((x), S48_STOBTYPE_PORT, 5))
+#define S48_UNSAFE_PORT_BUFFER(x) (S48_STOB_REF((x), 5))
+#define S48_SET_PORT_BUFFER(x, v) (s48_stob_ref((x), S48_STOBTYPE_PORT, 5, (v)))
+#define S48_UNSAFE_SET_PORT_BUFFER(x, v) S48_STOB_SET((x), 5, (v))
+#define S48_PORT_INDEX_OFFSET 6
+#define S48_PORT_INDEX(x) (s48_stob_ref((x), S48_STOBTYPE_PORT, 6))
+#define S48_UNSAFE_PORT_INDEX(x) (S48_STOB_REF((x), 6))
+#define S48_SET_PORT_INDEX(x, v) (s48_stob_ref((x), S48_STOBTYPE_PORT, 6, (v)))
+#define S48_UNSAFE_SET_PORT_INDEX(x, v) S48_STOB_SET((x), 6, (v))
+#define S48_PORT_LIMIT_OFFSET 7
+#define S48_PORT_LIMIT(x) (s48_stob_ref((x), S48_STOBTYPE_PORT, 7))
+#define S48_UNSAFE_PORT_LIMIT(x) (S48_STOB_REF((x), 7))
+#define S48_SET_PORT_LIMIT(x, v) (s48_stob_ref((x), S48_STOBTYPE_PORT, 7, (v)))
+#define S48_UNSAFE_SET_PORT_LIMIT(x, v) S48_STOB_SET((x), 7, (v))
+#define S48_PORT_PENDING_EOFP_OFFSET 8
+#define S48_PORT_PENDING_EOFP(x) (s48_stob_ref((x), S48_STOBTYPE_PORT, 8))
+#define S48_UNSAFE_PORT_PENDING_EOFP(x) (S48_STOB_REF((x), 8))
+#define S48_SET_PORT_PENDING_EOFP(x, v) (s48_stob_ref((x), S48_STOBTYPE_PORT, 8, (v)))
+#define S48_UNSAFE_SET_PORT_PENDING_EOFP(x, v) S48_STOB_SET((x), 8, (v))
+#define S48_CHANNEL_STATUS_OFFSET 0
+#define S48_CHANNEL_STATUS(x) (s48_stob_ref((x), S48_STOBTYPE_CHANNEL, 0))
+#define S48_UNSAFE_CHANNEL_STATUS(x) (S48_STOB_REF((x), 0))
+#define S48_CHANNEL_ID_OFFSET 1
+#define S48_CHANNEL_ID(x) (s48_stob_ref((x), S48_STOBTYPE_CHANNEL, 1))
+#define S48_UNSAFE_CHANNEL_ID(x) (S48_STOB_REF((x), 1))
+#define S48_CHANNEL_OS_INDEX_OFFSET 2
+#define S48_CHANNEL_OS_INDEX(x) (s48_stob_ref((x), S48_STOBTYPE_CHANNEL, 2))
+#define S48_UNSAFE_CHANNEL_OS_INDEX(x) (S48_STOB_REF((x), 2))
+
+#define S48_VECTOR_LENGTH(x) (s48_stob_length((x), S48_STOBTYPE_VECTOR))
+#define S48_UNSAFE_VECTOR_LENGTH(x) (STOB_DESCRIPTOR_LENGTH(x))
+#define S48_VECTOR_REF(x, i) (s48_stob_ref((x), S48_STOBTYPE_VECTOR, (i)))
+#define S48_VECTOR_SET(x, i, v) (s48_stob_set((x), S48_STOBTYPE_VECTOR, (i), (v)))
+#define S48_UNSAFE_VECTOR_REF(x, i) (S48_STOB_REF((x), (i)))
+#define S48_UNSAFE_VECTOR_SET(x, i, v) S48_STOB_SET((x), (i), (v))
+#define S48_RECORD_LENGTH(x) (s48_stob_length((x), S48_STOBTYPE_RECORD))
+#define S48_UNSAFE_RECORD_LENGTH(x) (STOB_DESCRIPTOR_LENGTH(x))
+#define S48_RECORD_REF(x, i) (s48_stob_ref((x), S48_STOBTYPE_RECORD, (i) + 1))
+#define S48_RECORD_SET(x, i, v) (s48_stob_set((x), S48_STOBTYPE_RECORD, (i) + 1, (v)))
+#define S48_UNSAFE_RECORD_REF(x, i) (S48_STOB_REF((x), (i) + 1))
+#define S48_UNSAFE_RECORD_SET(x, i, v) S48_STOB_SET((x), (i) + 1, (v))
+#define S48_RECORD_TYPE(x) (s48_stob_ref((x), S48_STOBTYPE_RECORD))
+#define S48_UNSAFE_RECORD_TYPE(x) (STOB_REF((x), 0))
+#define S48_BYTE_VECTOR_LENGTH(x) (s48_stob_byte_length((x), S48_STOBTYPE_BYTE_VECTOR))
+#define S48_BYTE_VECTOR_REF(x, i) (s48_stob_byte_ref((x), S48_STOBTYPE_BYTE_VECTOR, (i)))
+#define S48_BYTE_VECTOR_SET(x, i, v) (s48_stob_byte_set((x), S48_STOBTYPE_BYTE_VECTOR, (i), (v)))
+#define S48_UNSAFE_BYTE_VECTOR_REF(x, i) (S48_STOB_BYTE_REF((x), (i)))
+#define S48_UNSAFE_BYTE_VECTOR_SET(x, i, v) S48_BYTE_STOB_SET((x), (i), (v))
+#define S48_STRING_LENGTH(x) (s48_stob_byte_length((x), S48_STOBTYPE_STRING))
+#define S48_STRING_REF(x, i) (s48_stob_byte_ref((x), S48_STOBTYPE_STRING, (i)))
+#define S48_STRING_SET(x, i, v) (s48_stob_byte_set((x), S48_STOBTYPE_STRING, (i), (v)))
+#define S48_UNSAFE_STRING_REF(x, i) (S48_STOB_BYTE_REF((x), (i)))
+#define S48_UNSAFE_STRING_SET(x, i, v) S48_BYTE_STOB_SET((x), (i), (v))
+#define S48_UNSAFE_BYTE_VECTOR_LENGTH(x) (S48_STOB_BYTE_LENGTH(x))
+#define S48_UNSAFE_STRING_LENGTH(x) (S48_STOB_BYTE_LENGTH(x) - 1)
+#define S48_UNSAFE_EXTRACT_STRING(x) (S48_ADDRESS_AFTER_HEADER((x), char))
+#define S48_EXTRACT_EXTERNAL_OBJECT(x, type) ((type *)(S48_ADDRESS_AFTER_HEADER(x, long)+1))
+
+#define S48_RECORD_TYPE_RESUMER(x) S48_RECORD_REF((x), 0)
+#define S48_RECORD_TYPE_UID(x) S48_RECORD_REF((x), 1)
+#define S48_RECORD_TYPE_NAME(x) S48_RECORD_REF((x), 2)
+#define S48_RECORD_TYPE_FIELD_NAMES(x) S48_RECORD_REF((x), 3)
+#define S48_RECORD_TYPE_NUMBER_OF_FIELDS(x) S48_RECORD_REF((x), 4)
+#define S48_RECORD_TYPE_DISCLOSER(x) S48_RECORD_REF((x), 5)
+
+#define S48_EXCEPTION_UNASSIGNED_LOCAL 0
+#define S48_EXCEPTION_UNDEFINED_GLOBAL 1
+#define S48_EXCEPTION_UNBOUND_GLOBAL 2
+#define S48_EXCEPTION_BAD_PROCEDURE 3
+#define S48_EXCEPTION_WRONG_NUMBER_OF_ARGUMENTS 4
+#define S48_EXCEPTION_WRONG_TYPE_ARGUMENT 5
+#define S48_EXCEPTION_ARITHMETIC_OVERFLOW 6
+#define S48_EXCEPTION_INDEX_OUT_OF_RANGE 7
+#define S48_EXCEPTION_HEAP_OVERFLOW 8
+#define S48_EXCEPTION_OUT_OF_MEMORY 9
+#define S48_EXCEPTION_CANNOT_OPEN_CHANNEL 10
+#define S48_EXCEPTION_CHANNEL_OS_INDEX_ALREADY_IN_USE 11
+#define S48_EXCEPTION_CLOSED_CHANNEL 12
+#define S48_EXCEPTION_PENDING_CHANNEL_IO 13
+#define S48_EXCEPTION_BUFFER_FULLEMPTY 14
+#define S48_EXCEPTION_UNIMPLEMENTED_INSTRUCTION 15
+#define S48_EXCEPTION_TRAP 16
+#define S48_EXCEPTION_PROCEEDING_AFTER_EXCEPTION 17
+#define S48_EXCEPTION_BAD_OPTION 18
+#define S48_EXCEPTION_UNBOUND_EXTERNAL_NAME 19
+#define S48_EXCEPTION_TOO_MANY_ARGUMENTS_TO_EXTERNAL_PROCEDURE 20
+#define S48_EXCEPTION_TOO_MANY_ARGUMENTS_IN_CALLBACK 21
+#define S48_EXCEPTION_CALLBACK_RETURN_UNCOVERED 22
+#define S48_EXCEPTION_EXTENSION_EXCEPTION 23
+#define S48_EXCEPTION_EXTENSION_RETURN_ERROR 24
+#define S48_EXCEPTION_OS_ERROR 25
+#define S48_EXCEPTION_UNRESUMABLE_RECORDS_IN_IMAGE 26
+#define S48_EXCEPTION_GC_PROTECTION_MISMATCH 27
+
+#define S48_CHANNEL_STATUS_CLOSED S48_UNSAFE_ENTER_FIXNUM(0)
+#define S48_CHANNEL_STATUS_INPUT S48_UNSAFE_ENTER_FIXNUM(1)
+#define S48_CHANNEL_STATUS_OUTPUT S48_UNSAFE_ENTER_FIXNUM(2)
+#define S48_CHANNEL_STATUS_SPECIAL_INPUT S48_UNSAFE_ENTER_FIXNUM(3)
+#define S48_CHANNEL_STATUS_SPECIAL_OUTPUT S48_UNSAFE_ENTER_FIXNUM(4)
+
+#endif /* _H_SCHEME48 */
diff --git a/c/scheme48.h.in b/c/scheme48.h.in
new file mode 100644
index 0000000..2d3e533
--- /dev/null
+++ b/c/scheme48.h.in
@@ -0,0 +1,202 @@
+/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
+   See file COPYING. */
+
+#include "write-barrier.h"
+
+typedef long	s48_value;
+
+#define NO_ERRORS 0    /* errno value */
+
+/* Misc stuff */
+
+#define S48_EQ(v1, v2) ((v1) == (v2))
+
+#define S48_MAX_FIXNUM_VALUE ((1 << 29) - 1)
+#define S48_MIN_FIXNUM_VALUE (-1 << 29)
+
+extern int		s48_stob_has_type(s48_value, int);
+extern long		s48_stob_length(s48_value, int);
+extern long		s48_stob_byte_length(s48_value, int);
+extern s48_value	s48_stob_ref(s48_value, int, long);
+extern void		s48_stob_set(s48_value, int, long, s48_value);
+extern char		s48_stob_byte_ref(s48_value, int, long);
+extern void		s48_stob_byte_set(s48_value, int, long, char);
+
+extern void		s48_register_gc_rootB(char *);
+extern void		s48_push_gc_rootsB(char *, long);
+extern char		s48_pop_gc_rootsB(void);
+extern char		s48_pop_gc_roots_up_to_markerB(char *);
+
+extern s48_value	s48_enter_char(unsigned char);
+extern unsigned char	s48_extract_char(s48_value);
+extern s48_value	s48_enter_fixnum(long);
+extern long		s48_extract_fixnum(s48_value);
+extern s48_value	s48_enter_integer(long);
+extern long		s48_extract_integer(s48_value);
+extern s48_value	s48_enter_double(double);
+extern double		s48_extract_double(s48_value);
+extern s48_value	s48_cons(s48_value, s48_value);
+extern s48_value	s48_enter_string(char *);
+extern char *		s48_extract_string(s48_value);
+extern s48_value	s48_enter_substring(char *, int);
+extern s48_value	s48_make_string(int, char);
+extern s48_value	s48_make_vector(int, s48_value);
+extern s48_value	s48_make_byte_vector(int);
+extern s48_value	s48_make_record(s48_value);
+extern s48_value	s48_make_weak_pointer(s48_value);
+extern void		s48_check_record_type(s48_value, s48_value);
+extern long		s48_length(s48_value);
+extern s48_value	s48_enter_pointer(void *);
+extern s48_value	s48_get_imported_binding(char *);
+extern void		s48_define_exported_binding(char *, s48_value);
+
+extern s48_value	s48_set_channel_os_index(s48_value, long);
+extern s48_value	s48_add_channel(s48_value, s48_value, long);
+extern void		s48_close_channel(long);
+
+extern s48_value	s48_call_scheme(s48_value proc, long nargs, ...);
+
+#define S48_EXPORT_FUNCTION(p) (s48_define_exported_binding(#p, s48_enter_pointer(p)))
+
+#define S48_MAKE_VALUE(type) (s48_make_byte_vector(sizeof(type)))
+extern void *		s48_value_pointer(s48_value);
+
+#define S48_EXTRACT_VALUE_POINTER(x, type) ((type *) s48_value_pointer(x))
+#define S48_EXTRACT_VALUE(x, type) (*(S48_EXTRACT_VALUE_POINTER((x), type)))
+#define S48_SET_VALUE(x, type, v) (S48_EXTRACT_VALUE((x), type) = (v))
+
+#define S48_UNSAFE_EXTRACT_VALUE_POINTER(x, type)		\
+  (S48_ADDRESS_AFTER_HEADER((x), type))
+#define S48_UNSAFE_EXTRACT_VALUE(x, type)			\
+  (*(S48_UNSAFE_EXTRACT_VALUE_POINTER((x), type)))
+#define S48_UNSAFE_SET_VALUE(x, type, v)			\
+  (S48_UNSAFE_EXTRACT_VALUE((x), type) = (v))
+
+#define S48_UNSAFE_EXTRACT_DOUBLE(x)				\
+  (*(S48_ADDRESS_AFTER_HEADER((x), double)))
+
+#define S48_DECLARE_GC_PROTECT(n) long ___gc_buffer[(n)+2]
+
+#define S48_GC_PROTECT_1(v) \
+  (___gc_buffer[2]=(long)&(v), \
+   s48_push_gc_rootsB((char *) ___gc_buffer, 1))
+
+#define S48_GC_PROTECT_2(v1, v2) \
+  (___gc_buffer[2]=(long)&(v1), ___gc_buffer[3]=(long)&(v2), \
+   s48_push_gc_rootsB((char *) ___gc_buffer, 2))
+
+#define S48_GC_PROTECT_3(v1, v2, v3) \
+  (___gc_buffer[2]=(long)&(v1), \
+   ___gc_buffer[3]=(long)&(v2), \
+   ___gc_buffer[4]=(long)&(v3), \
+   s48_push_gc_rootsB((char *) ___gc_buffer, 3))
+
+#define S48_GC_PROTECT_4(v1, v2, v3, v4) \
+  (___gc_buffer[2]=(long)&(v1), \
+   ___gc_buffer[3]=(long)&(v2), \
+   ___gc_buffer[4]=(long)&(v3), \
+   ___gc_buffer[5]=(long)&(v4), \
+   s48_push_gc_rootsB((char *) ___gc_buffer, 4))
+
+#define S48_GC_PROTECT_5(v1, v2, v3, v4, v5) \
+  (___gc_buffer[2]=(long)&(v1), \
+   ___gc_buffer[3]=(long)&(v2), \
+   ___gc_buffer[4]=(long)&(v3), \
+   ___gc_buffer[5]=(long)&(v4), \
+   ___gc_buffer[6]=(long)&(v5), \
+   s48_push_gc_rootsB((char *) ___gc_buffer, 5))
+
+#define S48_GC_PROTECT_6(v1, v2, v3, v4, v5, v6) \
+  (___gc_buffer[2]=(long)&(v1), \
+   ___gc_buffer[3]=(long)&(v2), \
+   ___gc_buffer[4]=(long)&(v3), \
+   ___gc_buffer[5]=(long)&(v4), \
+   ___gc_buffer[6]=(long)&(v5), \
+   ___gc_buffer[7]=(long)&(v6), \
+   s48_push_gc_rootsB((char *) ___gc_buffer, 6))
+
+#define S48_GC_PROTECT_7(v1, v2, v3, v4, v5, v6, v7) \
+  (___gc_buffer[2]=(long)&(v1), \
+   ___gc_buffer[3]=(long)&(v2), \
+   ___gc_buffer[4]=(long)&(v3), \
+   ___gc_buffer[5]=(long)&(v4), \
+   ___gc_buffer[6]=(long)&(v5), \
+   ___gc_buffer[7]=(long)&(v6), \
+   ___gc_buffer[8]=(long)&(v7), \
+   s48_push_gc_rootsB((char *) ___gc_buffer, 7))
+
+#define S48_GC_PROTECT_8(v1, v2, v3, v4, v5, v6, v7, v8) \
+  (___gc_buffer[2]=(long)&(v1), \
+   ___gc_buffer[3]=(long)&(v2), \
+   ___gc_buffer[4]=(long)&(v3), \
+   ___gc_buffer[5]=(long)&(v4), \
+   ___gc_buffer[6]=(long)&(v5), \
+   ___gc_buffer[7]=(long)&(v6), \
+   ___gc_buffer[8]=(long)&(v7), \
+   ___gc_buffer[9]=(long)&(v8), \
+   s48_push_gc_rootsB((char *) ___gc_buffer, 8))
+
+#define S48_GC_PROTECT_9(v1, v2, v3, v4, v5, v6, v7, v8, v9) \
+  (___gc_buffer[2]=(long)&(v1), \
+   ___gc_buffer[3]=(long)&(v2), \
+   ___gc_buffer[4]=(long)&(v3), \
+   ___gc_buffer[5]=(long)&(v4), \
+   ___gc_buffer[6]=(long)&(v5), \
+   ___gc_buffer[7]=(long)&(v6), \
+   ___gc_buffer[8]=(long)&(v7), \
+   ___gc_buffer[9]=(long)&(v8), \
+   ___gc_buffer[10]=(long)&(v9), \
+   s48_push_gc_rootsB((char *) ___gc_buffer, 9))
+
+#define S48_GC_PROTECT_10(v1, v2, v3, v4, v5, v6, v7, v8, v9, v10) \
+  (___gc_buffer[2]=(long)&(v1), \
+   ___gc_buffer[3]=(long)&(v2), \
+   ___gc_buffer[4]=(long)&(v3), \
+   ___gc_buffer[5]=(long)&(v4), \
+   ___gc_buffer[6]=(long)&(v5), \
+   ___gc_buffer[7]=(long)&(v6), \
+   ___gc_buffer[8]=(long)&(v7), \
+   ___gc_buffer[9]=(long)&(v8), \
+   ___gc_buffer[10]=(long)&(v9), \
+   ___gc_buffer[11]=(long)&(v10), \
+   s48_push_gc_rootsB((char *) ___gc_buffer, 10))
+
+#define S48_GC_UNPROTECT()				\
+   do { if (! s48_pop_gc_rootsB())			\
+       	  s48_raise_scheme_exception( S48_EXCEPTION_GC_PROTECTION_MISMATCH, 0); \
+      } while(0)
+
+#define S48_GC_PROTECT_GLOBAL(v) (s48_register_gc_rootB((char *)&(v)))
+
+/* Exceptions */
+
+extern void s48_raise_scheme_exception(long type, long nargs, ...);
+extern void s48_raise_argtype_error(s48_value value);
+extern void s48_raise_argnumber_error(s48_value value,
+				  s48_value min, s48_value max);
+extern void s48_raise_range_error(s48_value value,
+			      s48_value min, s48_value max);
+extern void s48_raise_closed_channel_error();
+extern void s48_raise_os_error(int the_errno);
+extern void s48_raise_string_os_error(char *reason);
+extern void s48_raise_out_of_memory_error();
+
+/* Type checking */
+
+#define S48_CHECK_PAIR(v) do { if (!S48_PAIR_P(v)) s48_raise_argtype_error(v); } while (0)
+#define S48_CHECK_FIXNUM(v) do { if (!S48_FIXNUM_P(v)) s48_raise_argtype_error(v); } while (0)
+#define S48_CHECK_STRING(v) do { if (!S48_STRING_P(v)) s48_raise_argtype_error(v); } while (0)
+#define S48_CHECK_CHANNEL(v) do { if (!S48_CHANNEL_P(v)) s48_raise_argtype_error(v); } while (0)
+#define S48_CHECK_RECORD(v) do { if (!S48_RECORD_P(v)) s48_raise_argtype_error(v); } while (0)
+#define S48_CHECK_VALUE(v) do { if (!S48_BYTE_VECTOR_P(v)) s48_raise_argtype_error(v); } while (0)
+#define S48_CHECK_EXPORT_BINDING(v) do { if (!S48_EXPORT_BINDING_P(v)) s48_raise_argtype_error(v); } while (0)
+
+#define S48_VALUE_P(v) (S48_BYTE_VECTOR_P(v))
+
+extern void s48_check_record_type(s48_value record, s48_value type_binding);
+
+#define S48_SHARED_BINDING_CHECK(binding)					\
+  do { if (S48_UNSPECIFIC == S48_SHARED_BINDING_REF(binding))		\
+         s48_raise_scheme_exception(S48_EXCEPTION_UNBOUND_EXTERNAL_NAME, 1,	\
+				    S48_SHARED_BINDING_NAME(binding));	\
+  } while(0)
diff --git a/c/scheme48heap.c b/c/scheme48heap.c
new file mode 100644
index 0000000..9870e16
--- /dev/null
+++ b/c/scheme48heap.c
@@ -0,0 +1,2357 @@
+#include <stdio.h>
+#include "prescheme.h"
+#include "scheme48vm.h"
+
+static long copy_weak_pointer(long, char *, char **);
+static void clean_weak_pointers(void);
+static char gc_recordP(long);
+static void note_undumpableB(long);
+void s48_write_barrier(long, char *, long);
+long s48_heap_size(void);
+long s48_preallocate_space(long);
+void s48_register_static_areas(long, char **, long*, long, char **, long*);
+long s48_gc_count(void);
+void s48_end_collection(void);
+long s48_undumpable_records(long*);
+long s48_startup_procedure(void);
+long s48_initial_symbols(void);
+long s48_initial_imported_bindings(void);
+long s48_initial_exported_bindings(void);
+long s48_resumer_records(void);
+void s48_set_image_valuesB(long, long, long, long, long);
+void s48_initialization_completeB(void);
+void s48_initialize_heap(char *, long);
+char s48_availableP(long);
+char s48_image_writing_okayP(void);
+char * s48_allocate_space(long, long, long);
+long s48_available(void);
+char s48_extantP(long);
+long s48_check_image_header(char*);
+long s48_find_all(long);
+long s48_read_image(void);
+long s48_find_all_records(long);
+long s48_trace_locationsB(char *, char *);
+void s48_do_gc(void);
+long s48_trace_stob_contentsB(long);
+void s48_begin_collection(void);
+long s48_trace_value(long);
+long s48_write_image(long, FILE *);
+void s48_initializing_gc_root(void);
+static char * Soldspace_hpS;
+static char * Soldspace_limitS;
+static char * Snewspace_beginS;
+static char * Snewspace_endS;
+static char * Soldspace_beginS;
+static char * Soldspace_endS;
+static char * *Spure_areasS;
+static char * *Simpure_areasS;
+static long *Spure_sizesS;
+static long *Simpure_sizesS;
+static long Spure_area_countS;
+static long Simpure_area_countS;
+static long Sfinding_typeS;
+static long Sgc_countS;
+static char Swriting_imagePS;
+static long Sundumpable_recordsS;
+static long Sundumpable_countS;
+static char * Sfrom_beginS;
+static char * Sfrom_endS;
+static char * Sweak_pointer_hpS;
+static char * Sweak_pointer_limitS;
+static long SstatusS;
+static char SeofPS;
+static FILE * Simage_portS;
+static char * Sold_beginS;
+static char * Sold_hpS;
+static long Sstartup_procedureS;
+static long SsymbolsS;
+static long Simported_bindingsS;
+static long Sexported_bindingsS;
+static long Sresumer_recordsS;
+static char SinitializingPS;
+static long Hthe_record_type9260;
+char * s48_ShpS;
+char * s48_SlimitS;
+
+static long copy_weak_pointer(long weak_1X, char * frontier_2X, char * *TT0)
+{
+  char * arg0K0;
+  long new_7X;
+  char * frontier_6X;
+  char * new_frontier_5X;
+  char * old_4X;
+  char * x_3X;
+ {  x_3X = Sweak_pointer_hpS;
+  if ((x_3X == NULL)) {
+    goto L2423;}
+  else {
+    if (((Sweak_pointer_hpS) < (Sweak_pointer_limitS))) {
+      arg0K0 = frontier_2X;
+      goto L2428;}
+    else {
+      goto L2423;}}}
+ L2423: {
+  old_4X = Sweak_pointer_hpS;
+  new_frontier_5X = frontier_2X + 1024;
+  Sweak_pointer_hpS = frontier_2X;
+  Sweak_pointer_limitS = new_frontier_5X;
+  *((long *) (Sweak_pointer_hpS)) = 261190;
+  *((long *) ((Sweak_pointer_hpS) + 8)) = (((long) old_4X));
+  arg0K0 = new_frontier_5X;
+  goto L2428;}
+ L2428: {
+  frontier_6X = arg0K0;
+  new_7X = 3 + (((long) ((Sweak_pointer_hpS) + 4)));
+  *((long *) ((Sweak_pointer_hpS) + 4)) = (*((long *) (((char *) (-3 + weak_1X)))));
+  Sweak_pointer_hpS = ((Sweak_pointer_hpS) + 8);
+  *((long *) ((((char *) (-3 + weak_1X))) + -4)) = new_7X;
+  *TT0 = frontier_6X;
+  return new_7X;}
+}
+static void clean_weak_pointers(void)
+{
+  char * arg0K1;
+  char * arg0K0;
+  long arg1K0;
+  long x2_17X;
+  long h_16X;
+  char * a_15X;
+  long value_14X;
+  char * scan_13X;
+  char * next_12X;
+  char * end_11X;
+  char * start_10X;
+  char * end_9X;
+  char * x_8X;
+ {  if (((Sweak_pointer_hpS) == NULL)) {
+    return;}
+  else {
+    x_8X = Sweak_pointer_limitS;
+    end_9X = Sweak_pointer_hpS;
+    arg0K0 = (x_8X + -1024);
+    arg0K1 = end_9X;
+    goto L3994;}}
+ L3994: {
+  start_10X = arg0K0;
+  end_11X = arg0K1;
+  next_12X = ((char *) (*((long *) (start_10X + 8))));
+  arg0K0 = start_10X;
+  goto L2635;}
+ L2635: {
+  scan_13X = arg0K0;
+  if ((scan_13X < end_11X)) {
+    *((long *) scan_13X) = 1074;
+    value_14X = *((long *) (scan_13X + 4));
+    if ((3 == (3 & value_14X))) {
+      a_15X = ((char *) (-3 + value_14X));
+      if ((a_15X < (Sfrom_beginS))) {
+        goto L2681;}
+      else {
+        if ((a_15X < (Sfrom_endS))) {
+          if ((3 == (3 & value_14X))) {
+            h_16X = *((long *) ((((char *) (-3 + value_14X))) + -4));
+            if ((3 == (3 & h_16X))) {
+              arg1K0 = h_16X;
+              goto L2676;}
+            else {
+              arg1K0 = 1;
+              goto L2676;}}
+          else {
+            goto L2681;}}
+        else {
+          goto L2681;}}}
+    else {
+      goto L2681;}}
+  else {
+    if ((next_12X == NULL)) {
+      if ((end_9X < (Sweak_pointer_limitS))) {
+        *((long *) end_9X) = (70 + ((((-4 & ((Sweak_pointer_limitS) - (end_9X + 4))))<<8)));
+        return;}
+      else {
+        return;}}
+    else {
+      arg0K0 = (next_12X + -1024);
+      arg0K1 = next_12X;
+      goto L3994;}}}
+ L2681: {
+  arg0K0 = (scan_13X + 8);
+  goto L2635;}
+ L2676: {
+  x2_17X = arg1K0;
+  *((long *) (scan_13X + 4)) = x2_17X;
+  goto L2681;}
+}
+static char gc_recordP(long x_18X)
+{
+  long header_19X;
+ {  if ((3 == (3 & x_18X))) {
+    header_19X = *((long *) ((((char *) (-3 + x_18X))) + -4));
+    if ((3 == (3 & header_19X))) {
+      if ((3 == (3 & header_19X))) {
+        return (8 == (31 & ((((*((long *) ((((char *) (-3 + header_19X))) + -4))))>>2))));}
+      else {
+        return 0;}}
+    else {
+      if ((3 == (3 & x_18X))) {
+        return (8 == (31 & ((((*((long *) ((((char *) (-3 + x_18X))) + -4))))>>2))));}
+      else {
+        return 0;}}}
+  else {
+    return 0;}}
+}
+static void note_undumpableB(long thing_20X)
+{
+  long arg1K0;
+  char * temp_34X;
+  char * temp_33X;
+  char * temp_32X;
+  char * temp_31X;
+  long x_30X;
+  char * new_29X;
+  long b_28X;
+  char v_27X;
+  char * temp_26X;
+  char * temp_25X;
+  char * temp_24X;
+  char * temp_23X;
+  long list_22X;
+  long list_21X;
+ {  if ((1000 < (Sundumpable_countS))) {
+    return;}
+  else {
+    list_21X = Sundumpable_recordsS;
+    arg1K0 = list_21X;
+    goto L6367;}}
+ L6367: {
+  list_22X = arg1K0;
+  if ((25 == list_22X)) {
+    Sundumpable_countS = (1 + (Sundumpable_countS));
+    temp_23X = s48_SlimitS;
+    s48_SlimitS = (Soldspace_limitS);
+    Soldspace_limitS = temp_23X;
+    temp_24X = s48_ShpS;
+    s48_ShpS = (Soldspace_hpS);
+    Soldspace_hpS = temp_24X;
+    temp_25X = Snewspace_beginS;
+    Snewspace_beginS = (Soldspace_beginS);
+    Soldspace_beginS = temp_25X;
+    temp_26X = Snewspace_endS;
+    Snewspace_endS = (Soldspace_endS);
+    Soldspace_endS = temp_26X;
+    v_27X = ((s48_ShpS) + 12) < (s48_SlimitS);
+    if (v_27X) {
+      b_28X = Sundumpable_recordsS;
+      new_29X = s48_ShpS;
+      s48_ShpS = ((s48_ShpS) + 12);
+      *((long *) new_29X) = 2050;
+      x_30X = 3 + (((long) (new_29X + 4)));
+      *((long *) (((char *) (-3 + x_30X)))) = thing_20X;
+      *((long *) ((((char *) (-3 + x_30X))) + 4)) = b_28X;
+      Sundumpable_recordsS = x_30X;
+      goto L6289;}
+    else {
+      goto L6289;}}
+  else {
+    if (((*((long *) (((char *) (-3 + list_22X))))) == thing_20X)) {
+      return;}
+    else {
+      arg1K0 = (*((long *) ((((char *) (-3 + list_22X))) + 4)));
+      goto L6367;}}}
+ L6289: {
+  temp_31X = s48_SlimitS;
+  s48_SlimitS = (Soldspace_limitS);
+  Soldspace_limitS = temp_31X;
+  temp_32X = s48_ShpS;
+  s48_ShpS = (Soldspace_hpS);
+  Soldspace_hpS = temp_32X;
+  temp_33X = Snewspace_beginS;
+  Snewspace_beginS = (Soldspace_beginS);
+  Soldspace_beginS = temp_33X;
+  temp_34X = Snewspace_endS;
+  Snewspace_endS = (Soldspace_endS);
+  Soldspace_endS = temp_34X;
+  return;}
+}
+void s48_write_barrier(long stob_35X, char * address_36X, long value_37X)
+{
+
+ {  return;}
+}
+long s48_heap_size(void)
+{
+
+ {  return ((Snewspace_endS) - (Snewspace_beginS));}
+}
+long s48_preallocate_space(long cells_38X)
+{
+
+ {  return 0;}
+}
+void s48_register_static_areas(long pure_count_39X, char * *pure_areas_40X, long *pure_sizes_41X, long impure_count_42X, char * *impure_areas_43X, long *impure_sizes_44X)
+{
+
+ {  Spure_area_countS = pure_count_39X;
+  Spure_areasS = pure_areas_40X;
+  Spure_sizesS = pure_sizes_41X;
+  Simpure_area_countS = impure_count_42X;
+  Simpure_areasS = impure_areas_43X;
+  Simpure_sizesS = impure_sizes_44X;
+  return;}
+}
+long s48_gc_count(void)
+{
+
+ {  return (Sgc_countS);}
+}
+void s48_end_collection(void)
+{
+
+ {  Sgc_countS = (1 + (Sgc_countS));
+  return;}
+}
+long s48_undumpable_records(long *TT0)
+{
+
+ {  *TT0 = (Sundumpable_countS);
+  return (Sundumpable_recordsS);}
+}
+long s48_startup_procedure(void)
+{
+
+ {  return (Sstartup_procedureS);}
+}
+long s48_initial_symbols(void)
+{
+
+ {  return (SsymbolsS);}
+}
+long s48_initial_imported_bindings(void)
+{
+
+ {  return (Simported_bindingsS);}
+}
+long s48_initial_exported_bindings(void)
+{
+
+ {  return (Sexported_bindingsS);}
+}
+long s48_resumer_records(void)
+{
+
+ {  return (Sresumer_recordsS);}
+}
+void s48_set_image_valuesB(long startup_proc_45X, long symbols_46X, long imports_47X, long exports_48X, long records_49X)
+{
+
+ {  Sstartup_procedureS = startup_proc_45X;
+  SsymbolsS = symbols_46X;
+  Simported_bindingsS = imports_47X;
+  Sexported_bindingsS = exports_48X;
+  Sresumer_recordsS = records_49X;
+  return;}
+}
+void s48_initialization_completeB(void)
+{
+
+ {  SinitializingPS = 0;
+  return;}
+}
+void s48_initialize_heap(char * start_50X, long size_51X)
+{
+  long semisize_53X;
+  long cells_52X;
+ {  cells_52X = size_51X / 2;
+  semisize_53X = ((cells_52X)<<2);
+  Snewspace_beginS = start_50X;
+  Snewspace_endS = ((Snewspace_beginS) + semisize_53X);
+  s48_ShpS = (Snewspace_beginS);
+  s48_SlimitS = (Snewspace_endS);
+  Soldspace_beginS = (Snewspace_endS);
+  Soldspace_endS = ((Soldspace_beginS) + semisize_53X);
+  Soldspace_hpS = (Soldspace_beginS);
+  Soldspace_limitS = (Soldspace_endS);
+  return;}
+}
+char s48_availableP(long cells_54X)
+{
+
+ {  return (((s48_ShpS) + (((cells_54X)<<2))) < (s48_SlimitS));}
+}
+char s48_image_writing_okayP(void)
+{
+
+ {  if ((0 < (Simpure_area_countS))) {
+    return 0;}
+  else {
+    if ((0 < (Spure_area_countS))) {
+      return 0;}
+    else {
+      return 1;}}}
+}
+char * s48_allocate_space(long type_55X, long len_56X, long key_57X)
+{
+  char * new_58X;
+ {  new_58X = s48_ShpS;
+  s48_ShpS = ((s48_ShpS) + (-4 & (3 + len_56X)));
+  return new_58X;}
+}
+long s48_available(void)
+{
+
+ {  return (((((s48_SlimitS) - (s48_ShpS)))>>2));}
+}
+char s48_extantP(long thing_59X)
+{
+  char * a_60X;
+ {  if ((3 == (3 & thing_59X))) {
+    if ((3 == (3 & thing_59X))) {
+      a_60X = ((char *) (-3 + thing_59X));
+      if ((a_60X < (Sfrom_beginS))) {
+        return 1;}
+      else {
+        if ((a_60X < (Sfrom_endS))) {
+          return (3 == (3 & (*((long *) ((((char *) (-3 + thing_59X))) + -4)))));}
+        else {
+          return 1;}}}
+    else {
+      return 1;}}
+  else {
+    return 1;}}
+}
+long s48_check_image_header(char *filename_61X)
+{
+  long arg1K0;
+  long arg1K2;
+  long arg1K1;
+  char arg2K1;
+  char arg2K0;
+  long status_122X;
+  char eofP_121X;
+  long status_120X;
+  long status_119X;
+  long status_118X;
+  long status_117X;
+  long status_116X;
+  char eofP_115X;
+  char ch_114X;
+  long v_113X;
+  long status_112X;
+  char eofP_111X;
+  long thing_110X;
+  long v_109X;
+  long status_108X;
+  char eofP_107X;
+  long thing_106X;
+  long v_105X;
+  long status_104X;
+  char eofP_103X;
+  long thing_102X;
+  long v_101X;
+  long status_100X;
+  char eofP_99X;
+  long thing_98X;
+  long v_97X;
+  long status_96X;
+  char eofP_95X;
+  long thing_94X;
+  long cells_93X;
+  long status_92X;
+  char eofP_91X;
+  long thing_90X;
+  long cells_89X;
+  long status_88X;
+  char eofP_87X;
+  char thing_86X;
+  long status_85X;
+  char eofP_84X;
+  long thing_83X;
+  long old_bytes_per_cell_82X;
+  long status_81X;
+  char eofP_80X;
+  long status_79X;
+  char eofP_78X;
+  char ch_77X;
+  long i_76X;
+  long status_75X;
+  char eofP_74X;
+  long thing_73X;
+  char same_versionP_72X;
+  long status_71X;
+  char eofP_70X;
+  long status_69X;
+  char eofP_68X;
+  char ch_67X;
+  long status_66X;
+  char eofP_65X;
+  char ch_64X;
+  long status_63X;
+  FILE * port_62X;
+ {  port_62X = ps_open_input_file(filename_61X, &status_63X);
+  if ((status_63X == NO_ERRORS)) {
+    SstatusS = NO_ERRORS;
+    SeofPS = 0;
+    if ((SeofPS)) {
+      goto L2893;}
+    else {
+      goto L3626;}}
+  else {
+    ps_write_string("Can't open heap image file", (stderr));
+    { long ignoreXX;
+    PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+    ps_write_string((ps_error_string(status_63X)), (stderr));
+    { long ignoreXX;
+    PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+    return -1;}}
+ L2893: {
+  if ((SeofPS)) {
+    goto L2926;}
+  else {
+    goto L3590;}}
+ L3626: {
+  PS_READ_CHAR(port_62X, ch_64X, eofP_65X, status_66X)
+  if (eofP_65X) {
+    arg2K0 = eofP_65X;
+    arg1K1 = status_66X;
+    goto L2871;}
+  else {
+    if ((status_66X == NO_ERRORS)) {
+      if ((12 == ch_64X)) {
+        arg2K0 = 0;
+        arg1K1 = status_66X;
+        goto L2871;}
+      else {
+        goto L3626;}}
+    else {
+      arg2K0 = eofP_65X;
+      arg1K1 = status_66X;
+      goto L2871;}}}
+ L2926: {
+  if ((SeofPS)) {
+    arg2K0 = 0;
+    goto L2959;}
+  else {
+    arg1K0 = 0;
+    goto L3566;}}
+ L3590: {
+  PS_READ_CHAR(port_62X, ch_67X, eofP_68X, status_69X)
+  if (eofP_68X) {
+    arg2K0 = eofP_68X;
+    arg1K1 = status_69X;
+    goto L2904;}
+  else {
+    if ((status_69X == NO_ERRORS)) {
+      if ((10 == ch_67X)) {
+        arg2K0 = 0;
+        arg1K1 = status_69X;
+        goto L2904;}
+      else {
+        goto L3590;}}
+    else {
+      arg2K0 = eofP_68X;
+      arg1K1 = status_69X;
+      goto L2904;}}}
+ L2871: {
+  eofP_70X = arg2K0;
+  status_71X = arg1K1;
+  if (eofP_70X) {
+    SeofPS = 1;
+    goto L2893;}
+  else {
+    if (((SstatusS) == NO_ERRORS)) {
+      goto L2893;}
+    else {
+      SeofPS = 1;
+      SstatusS = status_71X;
+      goto L2893;}}}
+ L2959: {
+  same_versionP_72X = arg2K0;
+  if ((SeofPS)) {
+    arg1K0 = -1;
+    goto L2994;}
+  else {
+    PS_READ_INTEGER(port_62X, thing_73X, eofP_74X, status_75X)
+    if (eofP_74X) {
+      SeofPS = 1;
+      arg1K0 = -1;
+      goto L2994;}
+    else {
+      if (((SstatusS) == NO_ERRORS)) {
+        arg1K0 = thing_73X;
+        goto L2994;}
+      else {
+        SeofPS = 1;
+        SstatusS = status_75X;
+        arg1K0 = -1;
+        goto L2994;}}}}
+ L3566: {
+  i_76X = arg1K0;
+  PS_READ_CHAR(port_62X, ch_77X, eofP_78X, status_79X)
+  if (eofP_78X) {
+    arg2K0 = 0;
+    arg2K1 = eofP_78X;
+    arg1K2 = status_79X;
+    goto L2937;}
+  else {
+    if ((status_79X == NO_ERRORS)) {
+      if ((i_76X == (strlen((char *) "Vanilla 20")))) {
+        arg2K0 = (10 == ch_77X);
+        arg2K1 = 0;
+        arg1K2 = status_79X;
+        goto L2937;}
+      else {
+        if ((ch_77X == (*("Vanilla 20" + i_76X)))) {
+          arg1K0 = (1 + i_76X);
+          goto L3566;}
+        else {
+          arg2K0 = 0;
+          arg2K1 = 0;
+          arg1K2 = status_79X;
+          goto L2937;}}}
+    else {
+      arg2K0 = 0;
+      arg2K1 = eofP_78X;
+      arg1K2 = status_79X;
+      goto L2937;}}}
+ L2904: {
+  eofP_80X = arg2K0;
+  status_81X = arg1K1;
+  if (eofP_80X) {
+    SeofPS = 1;
+    goto L2926;}
+  else {
+    if (((SstatusS) == NO_ERRORS)) {
+      goto L2926;}
+    else {
+      SeofPS = 1;
+      SstatusS = status_81X;
+      goto L2926;}}}
+ L2994: {
+  old_bytes_per_cell_82X = arg1K0;
+  if ((SeofPS)) {
+    arg1K0 = -1;
+    goto L3029;}
+  else {
+    PS_READ_INTEGER(port_62X, thing_83X, eofP_84X, status_85X)
+    if (eofP_84X) {
+      SeofPS = 1;
+      arg1K0 = -1;
+      goto L3029;}
+    else {
+      if (((SstatusS) == NO_ERRORS)) {
+        arg1K0 = thing_83X;
+        goto L3029;}
+      else {
+        SeofPS = 1;
+        SstatusS = status_85X;
+        arg1K0 = -1;
+        goto L3029;}}}}
+ L2937: {
+  thing_86X = arg2K0;
+  eofP_87X = arg2K1;
+  status_88X = arg1K2;
+  if (eofP_87X) {
+    SeofPS = 1;
+    arg2K0 = 0;
+    goto L2959;}
+  else {
+    if (((SstatusS) == NO_ERRORS)) {
+      arg2K0 = thing_86X;
+      goto L2959;}
+    else {
+      SeofPS = 1;
+      SstatusS = status_88X;
+      arg2K0 = 0;
+      goto L2959;}}}
+ L3029: {
+  cells_89X = arg1K0;
+  Sold_beginS = (((char *) (((cells_89X)<<2))));
+  if ((SeofPS)) {
+    arg1K0 = -1;
+    goto L3067;}
+  else {
+    PS_READ_INTEGER(port_62X, thing_90X, eofP_91X, status_92X)
+    if (eofP_91X) {
+      SeofPS = 1;
+      arg1K0 = -1;
+      goto L3067;}
+    else {
+      if (((SstatusS) == NO_ERRORS)) {
+        arg1K0 = thing_90X;
+        goto L3067;}
+      else {
+        SeofPS = 1;
+        SstatusS = status_92X;
+        arg1K0 = -1;
+        goto L3067;}}}}
+ L3067: {
+  cells_93X = arg1K0;
+  Sold_hpS = (((char *) (((cells_93X)<<2))));
+  if ((SeofPS)) {
+    arg1K0 = -1;
+    goto L3105;}
+  else {
+    PS_READ_INTEGER(port_62X, thing_94X, eofP_95X, status_96X)
+    if (eofP_95X) {
+      SeofPS = 1;
+      arg1K0 = -1;
+      goto L3105;}
+    else {
+      if (((SstatusS) == NO_ERRORS)) {
+        arg1K0 = thing_94X;
+        goto L3105;}
+      else {
+        SeofPS = 1;
+        SstatusS = status_96X;
+        arg1K0 = -1;
+        goto L3105;}}}}
+ L3105: {
+  v_97X = arg1K0;
+  SsymbolsS = v_97X;
+  if ((SeofPS)) {
+    arg1K0 = -1;
+    goto L3141;}
+  else {
+    PS_READ_INTEGER(port_62X, thing_98X, eofP_99X, status_100X)
+    if (eofP_99X) {
+      SeofPS = 1;
+      arg1K0 = -1;
+      goto L3141;}
+    else {
+      if (((SstatusS) == NO_ERRORS)) {
+        arg1K0 = thing_98X;
+        goto L3141;}
+      else {
+        SeofPS = 1;
+        SstatusS = status_100X;
+        arg1K0 = -1;
+        goto L3141;}}}}
+ L3141: {
+  v_101X = arg1K0;
+  Simported_bindingsS = v_101X;
+  if ((SeofPS)) {
+    arg1K0 = -1;
+    goto L3177;}
+  else {
+    PS_READ_INTEGER(port_62X, thing_102X, eofP_103X, status_104X)
+    if (eofP_103X) {
+      SeofPS = 1;
+      arg1K0 = -1;
+      goto L3177;}
+    else {
+      if (((SstatusS) == NO_ERRORS)) {
+        arg1K0 = thing_102X;
+        goto L3177;}
+      else {
+        SeofPS = 1;
+        SstatusS = status_104X;
+        arg1K0 = -1;
+        goto L3177;}}}}
+ L3177: {
+  v_105X = arg1K0;
+  Sexported_bindingsS = v_105X;
+  if ((SeofPS)) {
+    arg1K0 = -1;
+    goto L3213;}
+  else {
+    PS_READ_INTEGER(port_62X, thing_106X, eofP_107X, status_108X)
+    if (eofP_107X) {
+      SeofPS = 1;
+      arg1K0 = -1;
+      goto L3213;}
+    else {
+      if (((SstatusS) == NO_ERRORS)) {
+        arg1K0 = thing_106X;
+        goto L3213;}
+      else {
+        SeofPS = 1;
+        SstatusS = status_108X;
+        arg1K0 = -1;
+        goto L3213;}}}}
+ L3213: {
+  v_109X = arg1K0;
+  Sresumer_recordsS = v_109X;
+  if ((SeofPS)) {
+    arg1K0 = -1;
+    goto L3249;}
+  else {
+    PS_READ_INTEGER(port_62X, thing_110X, eofP_111X, status_112X)
+    if (eofP_111X) {
+      SeofPS = 1;
+      arg1K0 = -1;
+      goto L3249;}
+    else {
+      if (((SstatusS) == NO_ERRORS)) {
+        arg1K0 = thing_110X;
+        goto L3249;}
+      else {
+        SeofPS = 1;
+        SstatusS = status_112X;
+        arg1K0 = -1;
+        goto L3249;}}}}
+ L3249: {
+  v_113X = arg1K0;
+  Sstartup_procedureS = v_113X;
+  Simage_portS = port_62X;
+  if ((SeofPS)) {
+    goto L3288;}
+  else {
+    goto L3497;}}
+ L3288: {
+  if (((SstatusS) == NO_ERRORS)) {
+    if ((SeofPS)) {
+      SstatusS = EDOM;
+      ps_write_string("Premature EOF when reading image file", (stderr));
+      { long ignoreXX;
+      PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+      if (((SstatusS) == NO_ERRORS)) {
+        goto L3369;}
+      else {
+        ps_write_string((ps_error_string((SstatusS))), (stderr));
+        { long ignoreXX;
+        PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+        goto L3369;}}
+    else {
+      if (same_versionP_72X) {
+        if ((4 == old_bytes_per_cell_82X)) {
+          return ((Sold_hpS) - (Sold_beginS));}
+        else {
+          ps_write_string("Incompatible bytes-per-cell in image", (stderr));
+          { long ignoreXX;
+          PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+          if (((SstatusS) == NO_ERRORS)) {
+            goto L3429;}
+          else {
+            ps_write_string((ps_error_string((SstatusS))), (stderr));
+            { long ignoreXX;
+            PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+            goto L3429;}}}
+      else {
+        ps_write_string("Format of image is incompatible with this version of system", (stderr));
+        { long ignoreXX;
+        PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+        if (((SstatusS) == NO_ERRORS)) {
+          goto L3399;}
+        else {
+          ps_write_string((ps_error_string((SstatusS))), (stderr));
+          { long ignoreXX;
+          PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+          goto L3399;}}}}
+  else {
+    ps_write_string("Error reading from image file", (stderr));
+    { long ignoreXX;
+    PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+    if (((SstatusS) == NO_ERRORS)) {
+      goto L3344;}
+    else {
+      ps_write_string((ps_error_string((SstatusS))), (stderr));
+      { long ignoreXX;
+      PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+      goto L3344;}}}
+ L3497: {
+  PS_READ_CHAR(port_62X, ch_114X, eofP_115X, status_116X)
+  if (eofP_115X) {
+    arg2K0 = eofP_115X;
+    arg1K1 = status_116X;
+    goto L3266;}
+  else {
+    if ((status_116X == NO_ERRORS)) {
+      if ((12 == ch_114X)) {
+        arg2K0 = 0;
+        arg1K1 = status_116X;
+        goto L3266;}
+      else {
+        goto L3497;}}
+    else {
+      arg2K0 = eofP_115X;
+      arg1K1 = status_116X;
+      goto L3266;}}}
+ L3369: {
+  status_117X = ps_close(port_62X);
+  if ((status_117X == NO_ERRORS)) {
+    return -1;}
+  else {
+    ps_write_string("Error closing image file", (stderr));
+    { long ignoreXX;
+    PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+    return -1;}}
+ L3429: {
+  status_118X = ps_close(port_62X);
+  if ((status_118X == NO_ERRORS)) {
+    return -1;}
+  else {
+    ps_write_string("Error closing image file", (stderr));
+    { long ignoreXX;
+    PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+    return -1;}}
+ L3399: {
+  status_119X = ps_close(port_62X);
+  if ((status_119X == NO_ERRORS)) {
+    return -1;}
+  else {
+    ps_write_string("Error closing image file", (stderr));
+    { long ignoreXX;
+    PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+    return -1;}}
+ L3344: {
+  status_120X = ps_close(port_62X);
+  if ((status_120X == NO_ERRORS)) {
+    return -1;}
+  else {
+    ps_write_string("Error closing image file", (stderr));
+    { long ignoreXX;
+    PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+    return -1;}}
+ L3266: {
+  eofP_121X = arg2K0;
+  status_122X = arg1K1;
+  if (eofP_121X) {
+    SeofPS = 1;
+    goto L3288;}
+  else {
+    if (((SstatusS) == NO_ERRORS)) {
+      goto L3288;}
+    else {
+      SeofPS = 1;
+      SstatusS = status_122X;
+      goto L3288;}}}
+}
+long s48_find_all(long type_123X)
+{
+  char * arg0K0;
+  long arg1K0;
+  char * merged_arg0K1;
+  char * merged_arg0K0;
+
+  int Hproc923124_return_tag;
+  char Hproc9231240_return_value;
+  char * start_125X;
+  char * end_126X;
+  char * next_142X;
+  long d_141X;
+  char * addr_140X;
+  long type_139X;
+  char v_138X;
+  long i_137X;
+  long count_136X;
+  long *sizes_135X;
+  char * *areas_134X;
+  char v_133X;
+  long i_132X;
+  long count_131X;
+  long *sizes_130X;
+  char * *areas_129X;
+  char v_128X;
+  char * start_hp_127X;
+ {  Sfinding_typeS = type_123X;
+  start_hp_127X = s48_ShpS;
+  *((long *) (s48_ShpS)) = 0;
+  s48_ShpS = ((s48_ShpS) + 4);
+  merged_arg0K0 = (Snewspace_beginS);
+  merged_arg0K1 = start_hp_127X;
+  Hproc923124_return_tag = 0;
+  goto Hproc923124;
+ Hproc923124_return_0:
+  v_128X = Hproc9231240_return_value;
+  if (v_128X) {
+    if ((0 < (Simpure_area_countS))) {
+      areas_129X = Simpure_areasS;
+      sizes_130X = Simpure_sizesS;
+      count_131X = Simpure_area_countS;
+      arg1K0 = 0;
+      goto L5577;}
+    else {
+      goto L5517;}}
+  else {
+    goto L5535;}}
+ L5577: {
+  i_132X = arg1K0;
+  if ((i_132X < count_131X)) {
+    merged_arg0K0 = (*(areas_129X + i_132X));
+    merged_arg0K1 = ((*(areas_129X + i_132X)) + (*(sizes_130X + i_132X)));
+    Hproc923124_return_tag = 1;
+    goto Hproc923124;
+   Hproc923124_return_1:
+    v_133X = Hproc9231240_return_value;
+    if (v_133X) {
+      arg1K0 = (1 + i_132X);
+      goto L5577;}
+    else {
+      goto L5535;}}
+  else {
+    goto L5517;}}
+ L5517: {
+  if ((0 < (Spure_area_countS))) {
+    areas_134X = Spure_areasS;
+    sizes_135X = Spure_sizesS;
+    count_136X = Spure_area_countS;
+    arg1K0 = 0;
+    goto L5598;}
+  else {
+    goto L5524;}}
+ L5535: {
+  s48_ShpS = start_hp_127X;
+  return 1;}
+ L5598: {
+  i_137X = arg1K0;
+  if ((i_137X < count_136X)) {
+    merged_arg0K0 = (*(areas_134X + i_137X));
+    merged_arg0K1 = ((*(areas_134X + i_137X)) + (*(sizes_135X + i_137X)));
+    Hproc923124_return_tag = 2;
+    goto Hproc923124;
+   Hproc923124_return_2:
+    v_138X = Hproc9231240_return_value;
+    if (v_138X) {
+      arg1K0 = (1 + i_137X);
+      goto L5598;}
+    else {
+      goto L5535;}}
+  else {
+    goto L5524;}}
+ L5524: {
+  *((long *) start_hp_127X) = (10 + (((((s48_ShpS) - (start_hp_127X + 4)))<<8)));
+  return (3 + (((long) (start_hp_127X + 4))));}
+ Hproc923124: {
+  start_125X = merged_arg0K0;
+  end_126X = merged_arg0K1;{
+  type_139X = Sfinding_typeS;
+  arg0K0 = start_125X;
+  goto L4503;}
+ L4503: {
+  addr_140X = arg0K0;
+  if ((addr_140X < end_126X)) {
+    d_141X = *((long *) addr_140X);
+    next_142X = addr_140X + (4 + (-4 & (3 + ((long)(((unsigned long)d_141X)>>8)))));
+    if ((2 == (3 & d_141X))) {
+      if ((type_139X == (31 & (((d_141X)>>2))))) {
+        if ((((s48_ShpS) + 16) < (s48_SlimitS))) {
+          *((long *) (s48_ShpS)) = (3 + (((long) (addr_140X + 4))));
+          s48_ShpS = ((s48_ShpS) + 4);
+          arg0K0 = next_142X;
+          goto L4503;}
+        else {
+          Hproc9231240_return_value = 0;
+          goto Hproc923124_return;}}
+      else {
+        arg0K0 = next_142X;
+        goto L4503;}}
+    else {
+      ps_write_string("heap is in an inconsistent state.", (stderr));
+      Hproc9231240_return_value = 0;
+      goto Hproc923124_return;}}
+  else {
+    Hproc9231240_return_value = 1;
+    goto Hproc923124_return;}}
+ Hproc923124_return:
+  switch (Hproc923124_return_tag) {
+  case 0: goto Hproc923124_return_0;
+  case 1: goto Hproc923124_return_1;
+  default: goto Hproc923124_return_2;
+  }}
+
+}
+long s48_read_image(void)
+{
+  FILE * arg4K0;
+  char *arg3K1;
+  char arg2K1;
+  char arg2K0;
+  char * arg0K0;
+  long arg1K0;
+  long v_192X;
+  long descriptor_191X;
+  long v_190X;
+  long descriptor_189X;
+  long v_188X;
+  long descriptor_187X;
+  long v_186X;
+  long d_185X;
+  long descriptor_184X;
+  long v_183X;
+  long descriptor_182X;
+  char * ptr_181X;
+  long descriptor_180X;
+  long status_179X;
+  long status_178X;
+  long status_177X;
+  long status_176X;
+  char * next_175X;
+  long value_174X;
+  long x_173X;
+  long x_172X;
+  char * ptr_171X;
+  long status_170X;
+  long status_169X;
+  long status_168X;
+  char eofP_167X;
+  char v_166X;
+  char *string_165X;
+  char okayP_164X;
+  long status_163X;
+  long status_162X;
+  long status_161X;
+  char eofP_160X;
+  long got_159X;
+  long need_158X;
+  char * start_157X;
+  char * new_limit_156X;
+  char * new_hp_155X;
+  long delta_154X;
+  char reverseP_153X;
+  FILE * port_152X;
+  long x_151X;
+  long x_150X;
+  char * addr_149X;
+  char *string_148X;
+  char okayP_147X;
+  long status_146X;
+  char eofP_145X;
+  long got_144X;
+  FILE * port_143X;
+ {  port_143X = Simage_portS;
+  got_144X = ps_read_block(port_143X, ((char *) (s48_ShpS)), 4, &eofP_145X, &status_146X);
+  if ((status_146X == NO_ERRORS)) {
+    if (eofP_145X) {
+      arg2K0 = 0;
+      arg3K1 = "Premature EOF when reading image file";
+      goto L6079;}
+    else {
+      if ((got_144X < 4)) {
+        arg2K0 = 0;
+        arg3K1 = "Read returned too few bytes";
+        goto L6079;}
+      else {
+        arg2K0 = 1;
+        arg3K1 = "";
+        goto L6079;}}}
+  else {
+    SstatusS = status_146X;
+    arg2K0 = 0;
+    arg3K1 = "Error reading from image file";
+    goto L6079;}}
+ L6079: {
+  okayP_147X = arg2K0;
+  string_148X = arg3K1;
+  if (okayP_147X) {
+    if ((1 == (*((long *) (s48_ShpS))))) {
+      arg4K0 = port_143X;
+      arg2K1 = 0;
+      goto L5092;}
+    else {
+      addr_149X = s48_ShpS;
+      x_150X = *((unsigned char *) addr_149X);
+      *((unsigned char *) addr_149X) = (*((unsigned char *) (addr_149X + 3)));
+      *((unsigned char *) (addr_149X + 3)) = x_150X;
+      x_151X = *((unsigned char *) (addr_149X + 1));
+      *((unsigned char *) (addr_149X + 1)) = (*((unsigned char *) (addr_149X + 2)));
+      *((unsigned char *) (addr_149X + 2)) = x_151X;
+      if ((1 == (*((long *) (s48_ShpS))))) {
+        arg4K0 = port_143X;
+        arg2K1 = 1;
+        goto L5092;}
+      else {
+        ps_write_string("Unable to correct byte order", (stderr));
+        { long ignoreXX;
+        PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+        if (((SstatusS) == NO_ERRORS)) {
+          goto L6187;}
+        else {
+          ps_write_string((ps_error_string((SstatusS))), (stderr));
+          { long ignoreXX;
+          PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+          goto L6187;}}}}
+  else {
+    ps_write_string(string_148X, (stderr));
+    { long ignoreXX;
+    PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+    if (((SstatusS) == NO_ERRORS)) {
+      goto L6135;}
+    else {
+      ps_write_string((ps_error_string((SstatusS))), (stderr));
+      { long ignoreXX;
+      PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+      goto L6135;}}}
+ L5092: {
+  port_152X = arg4K0;
+  reverseP_153X = arg2K1;
+  delta_154X = (s48_ShpS) - (Sold_beginS);
+  new_hp_155X = (Sold_hpS) + delta_154X;
+  new_limit_156X = Snewspace_endS;
+  start_157X = s48_ShpS;
+  if ((new_hp_155X < new_limit_156X)) {
+    need_158X = (Sold_hpS) - (Sold_beginS);
+    got_159X = ps_read_block(port_152X, ((char *) (s48_ShpS)), need_158X, &eofP_160X, &status_161X);
+    if ((status_161X == NO_ERRORS)) {
+      if (eofP_160X) {
+        arg2K0 = 0;
+        arg3K1 = "Premature EOF when reading image file";
+        goto L5114;}
+      else {
+        if ((got_159X < need_158X)) {
+          arg2K0 = 0;
+          arg3K1 = "Read returned too few bytes";
+          goto L5114;}
+        else {
+          arg2K0 = 1;
+          arg3K1 = "";
+          goto L5114;}}}
+    else {
+      SstatusS = status_161X;
+      arg2K0 = 0;
+      arg3K1 = "Error reading from image file";
+      goto L5114;}}
+  else {
+    ps_write_string("Heap not big enough to restore this image", (stderr));
+    { long ignoreXX;
+    PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+    if (((SstatusS) == NO_ERRORS)) {
+      goto L5210;}
+    else {
+      ps_write_string((ps_error_string((SstatusS))), (stderr));
+      { long ignoreXX;
+      PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+      goto L5210;}}}
+ L6187: {
+  status_162X = ps_close(port_143X);
+  if ((status_162X == NO_ERRORS)) {
+    return -1;}
+  else {
+    ps_write_string("Error closing image file", (stderr));
+    { long ignoreXX;
+    PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+    return -1;}}
+ L6135: {
+  status_163X = ps_close(port_143X);
+  if ((status_163X == NO_ERRORS)) {
+    return -1;}
+  else {
+    ps_write_string("Error closing image file", (stderr));
+    { long ignoreXX;
+    PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+    return -1;}}
+ L5114: {
+  okayP_164X = arg2K0;
+  string_165X = arg3K1;
+  PS_READ_CHAR(port_152X, v_166X, eofP_167X, status_168X)
+  if (okayP_164X) {
+    if ((status_168X == NO_ERRORS)) {
+      if (eofP_167X) {
+        status_169X = ps_close(port_152X);
+        if ((status_169X == NO_ERRORS)) {
+          if (reverseP_153X) {
+            ps_write_string("Correcting byte order of resumed image.", (stderr));
+            { long ignoreXX;
+            PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+            arg0K0 = start_157X;
+            goto L4309;}
+          else {
+            goto L5152;}}
+        else {
+          ps_write_string("Error closing image file", (stderr));
+          { long ignoreXX;
+          PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+          if (((SstatusS) == NO_ERRORS)) {
+            goto L5345;}
+          else {
+            ps_write_string((ps_error_string((SstatusS))), (stderr));
+            { long ignoreXX;
+            PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+            goto L5345;}}}
+      else {
+        ps_write_string("Image file has extraneous data after image", (stderr));
+        { long ignoreXX;
+        PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+        if (((SstatusS) == NO_ERRORS)) {
+          goto L5315;}
+        else {
+          ps_write_string((ps_error_string((SstatusS))), (stderr));
+          { long ignoreXX;
+          PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+          goto L5315;}}}
+    else {
+      ps_write_string("Error reading from image file", (stderr));
+      { long ignoreXX;
+      PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+      if (((SstatusS) == NO_ERRORS)) {
+        goto L5285;}
+      else {
+        ps_write_string((ps_error_string((SstatusS))), (stderr));
+        { long ignoreXX;
+        PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+        goto L5285;}}}
+  else {
+    ps_write_string(string_165X, (stderr));
+    { long ignoreXX;
+    PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+    if (((SstatusS) == NO_ERRORS)) {
+      goto L5255;}
+    else {
+      ps_write_string((ps_error_string((SstatusS))), (stderr));
+      { long ignoreXX;
+      PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+      goto L5255;}}}
+ L5210: {
+  status_170X = ps_close(port_152X);
+  if ((status_170X == NO_ERRORS)) {
+    return -1;}
+  else {
+    ps_write_string("Error closing image file", (stderr));
+    { long ignoreXX;
+    PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+    return -1;}}
+ L4309: {
+  ptr_171X = arg0K0;
+  if ((ptr_171X < new_hp_155X)) {
+    x_172X = *((unsigned char *) ptr_171X);
+    *((unsigned char *) ptr_171X) = (*((unsigned char *) (ptr_171X + 3)));
+    *((unsigned char *) (ptr_171X + 3)) = x_172X;
+    x_173X = *((unsigned char *) (ptr_171X + 1));
+    *((unsigned char *) (ptr_171X + 1)) = (*((unsigned char *) (ptr_171X + 2)));
+    *((unsigned char *) (ptr_171X + 2)) = x_173X;
+    value_174X = *((long *) ptr_171X);
+    next_175X = ptr_171X + 4;
+    if ((2 == (3 & value_174X))) {
+      if (((31 & (((value_174X)>>2))) < 16)) {
+        arg0K0 = next_175X;
+        goto L4309;}
+      else {
+        arg0K0 = (next_175X + (-4 & (3 + ((long)(((unsigned long)value_174X)>>8)))));
+        goto L4309;}}
+    else {
+      arg0K0 = next_175X;
+      goto L4309;}}
+  else {
+    goto L5152;}}
+ L5152: {
+  if ((0 == delta_154X)) {
+    goto L5162;}
+  else {
+    arg0K0 = start_157X;
+    goto L4408;}}
+ L5345: {
+  status_176X = ps_close(port_152X);
+  if ((status_176X == NO_ERRORS)) {
+    return -1;}
+  else {
+    ps_write_string("Error closing image file", (stderr));
+    { long ignoreXX;
+    PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+    return -1;}}
+ L5315: {
+  status_177X = ps_close(port_152X);
+  if ((status_177X == NO_ERRORS)) {
+    return -1;}
+  else {
+    ps_write_string("Error closing image file", (stderr));
+    { long ignoreXX;
+    PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+    return -1;}}
+ L5285: {
+  status_178X = ps_close(port_152X);
+  if ((status_178X == NO_ERRORS)) {
+    return -1;}
+  else {
+    ps_write_string("Error closing image file", (stderr));
+    { long ignoreXX;
+    PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+    return -1;}}
+ L5255: {
+  status_179X = ps_close(port_152X);
+  if ((status_179X == NO_ERRORS)) {
+    return -1;}
+  else {
+    ps_write_string("Error closing image file", (stderr));
+    { long ignoreXX;
+    PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+    return -1;}}
+ L5162: {
+  s48_ShpS = new_hp_155X;
+  descriptor_180X = Sstartup_procedureS;
+  if ((3 == (3 & descriptor_180X))) {
+    arg1K0 = (3 + (((long) ((((char *) (-3 + descriptor_180X))) + delta_154X))));
+    goto L5166;}
+  else {
+    arg1K0 = descriptor_180X;
+    goto L5166;}}
+ L4408: {
+  ptr_181X = arg0K0;
+  if ((ptr_181X < new_hp_155X)) {
+    descriptor_182X = *((long *) ptr_181X);
+    if ((3 == (3 & descriptor_182X))) {
+      arg1K0 = (3 + (((long) ((((char *) (-3 + descriptor_182X))) + delta_154X))));
+      goto L4413;}
+    else {
+      arg1K0 = descriptor_182X;
+      goto L4413;}}
+  else {
+    goto L5162;}}
+ L5166: {
+  v_183X = arg1K0;
+  Sstartup_procedureS = v_183X;
+  descriptor_184X = SsymbolsS;
+  if ((3 == (3 & descriptor_184X))) {
+    arg1K0 = (3 + (((long) ((((char *) (-3 + descriptor_184X))) + delta_154X))));
+    goto L5171;}
+  else {
+    arg1K0 = descriptor_184X;
+    goto L5171;}}
+ L4413: {
+  d_185X = arg1K0;
+  *((long *) ptr_181X) = d_185X;
+  if ((2 == (3 & d_185X))) {
+    if (((31 & (((d_185X)>>2))) < 16)) {
+      goto L4427;}
+    else {
+      arg0K0 = (ptr_181X + (4 + (-4 & (3 + ((long)(((unsigned long)d_185X)>>8))))));
+      goto L4408;}}
+  else {
+    goto L4427;}}
+ L5171: {
+  v_186X = arg1K0;
+  SsymbolsS = v_186X;
+  descriptor_187X = Simported_bindingsS;
+  if ((3 == (3 & descriptor_187X))) {
+    arg1K0 = (3 + (((long) ((((char *) (-3 + descriptor_187X))) + delta_154X))));
+    goto L5176;}
+  else {
+    arg1K0 = descriptor_187X;
+    goto L5176;}}
+ L4427: {
+  arg0K0 = (ptr_181X + 4);
+  goto L4408;}
+ L5176: {
+  v_188X = arg1K0;
+  Simported_bindingsS = v_188X;
+  descriptor_189X = Sexported_bindingsS;
+  if ((3 == (3 & descriptor_189X))) {
+    arg1K0 = (3 + (((long) ((((char *) (-3 + descriptor_189X))) + delta_154X))));
+    goto L5181;}
+  else {
+    arg1K0 = descriptor_189X;
+    goto L5181;}}
+ L5181: {
+  v_190X = arg1K0;
+  Sexported_bindingsS = v_190X;
+  descriptor_191X = Sresumer_recordsS;
+  if ((3 == (3 & descriptor_191X))) {
+    arg1K0 = (3 + (((long) ((((char *) (-3 + descriptor_191X))) + delta_154X))));
+    goto L5186;}
+  else {
+    arg1K0 = descriptor_191X;
+    goto L5186;}}
+ L5186: {
+  v_192X = arg1K0;
+  Sresumer_recordsS = v_192X;
+  return 0;}
+}
+long s48_find_all_records(long record_type_193X)
+{
+  char * arg0K0;
+  long arg1K0;
+  char * merged_arg0K1;
+  char * merged_arg0K0;
+
+  int Hproc969194_return_tag;
+  char Hproc9691940_return_value;
+  char * start_195X;
+  char * end_196X;
+  long obj_213X;
+  char * next_212X;
+  long d_211X;
+  char * addr_210X;
+  long type_209X;
+  char v_208X;
+  long i_207X;
+  long count_206X;
+  long *sizes_205X;
+  char * *areas_204X;
+  char v_203X;
+  long i_202X;
+  long count_201X;
+  long *sizes_200X;
+  char * *areas_199X;
+  char v_198X;
+  char * start_hp_197X;
+ {  Hthe_record_type9260 = record_type_193X;
+  Sfinding_typeS = 8;
+  start_hp_197X = s48_ShpS;
+  *((long *) (s48_ShpS)) = 0;
+  s48_ShpS = ((s48_ShpS) + 4);
+  merged_arg0K0 = (Snewspace_beginS);
+  merged_arg0K1 = start_hp_197X;
+  Hproc969194_return_tag = 0;
+  goto Hproc969194;
+ Hproc969194_return_0:
+  v_198X = Hproc9691940_return_value;
+  if (v_198X) {
+    if ((0 < (Simpure_area_countS))) {
+      areas_199X = Simpure_areasS;
+      sizes_200X = Simpure_sizesS;
+      count_201X = Simpure_area_countS;
+      arg1K0 = 0;
+      goto L5742;}
+    else {
+      goto L5682;}}
+  else {
+    goto L5700;}}
+ L5742: {
+  i_202X = arg1K0;
+  if ((i_202X < count_201X)) {
+    merged_arg0K0 = (*(areas_199X + i_202X));
+    merged_arg0K1 = ((*(areas_199X + i_202X)) + (*(sizes_200X + i_202X)));
+    Hproc969194_return_tag = 1;
+    goto Hproc969194;
+   Hproc969194_return_1:
+    v_203X = Hproc9691940_return_value;
+    if (v_203X) {
+      arg1K0 = (1 + i_202X);
+      goto L5742;}
+    else {
+      goto L5700;}}
+  else {
+    goto L5682;}}
+ L5682: {
+  if ((0 < (Spure_area_countS))) {
+    areas_204X = Spure_areasS;
+    sizes_205X = Spure_sizesS;
+    count_206X = Spure_area_countS;
+    arg1K0 = 0;
+    goto L5763;}
+  else {
+    goto L5689;}}
+ L5700: {
+  s48_ShpS = start_hp_197X;
+  return 1;}
+ L5763: {
+  i_207X = arg1K0;
+  if ((i_207X < count_206X)) {
+    merged_arg0K0 = (*(areas_204X + i_207X));
+    merged_arg0K1 = ((*(areas_204X + i_207X)) + (*(sizes_205X + i_207X)));
+    Hproc969194_return_tag = 2;
+    goto Hproc969194;
+   Hproc969194_return_2:
+    v_208X = Hproc9691940_return_value;
+    if (v_208X) {
+      arg1K0 = (1 + i_207X);
+      goto L5763;}
+    else {
+      goto L5700;}}
+  else {
+    goto L5689;}}
+ L5689: {
+  *((long *) start_hp_197X) = (10 + (((((s48_ShpS) - (start_hp_197X + 4)))<<8)));
+  return (3 + (((long) (start_hp_197X + 4))));}
+ Hproc969194: {
+  start_195X = merged_arg0K0;
+  end_196X = merged_arg0K1;{
+  type_209X = Sfinding_typeS;
+  arg0K0 = start_195X;
+  goto L4670;}
+ L4670: {
+  addr_210X = arg0K0;
+  if ((addr_210X < end_196X)) {
+    d_211X = *((long *) addr_210X);
+    next_212X = addr_210X + (4 + (-4 & (3 + ((long)(((unsigned long)d_211X)>>8)))));
+    if ((2 == (3 & d_211X))) {
+      if ((type_209X == (31 & (((d_211X)>>2))))) {
+        obj_213X = 3 + (((long) (addr_210X + 4)));
+        if (((*((long *) (((char *) (-3 + obj_213X))))) == (Hthe_record_type9260))) {
+          if ((((s48_ShpS) + 16) < (s48_SlimitS))) {
+            *((long *) (s48_ShpS)) = obj_213X;
+            s48_ShpS = ((s48_ShpS) + 4);
+            arg0K0 = next_212X;
+            goto L4670;}
+          else {
+            Hproc9691940_return_value = 0;
+            goto Hproc969194_return;}}
+        else {
+          arg0K0 = next_212X;
+          goto L4670;}}
+      else {
+        arg0K0 = next_212X;
+        goto L4670;}}
+    else {
+      ps_write_string("heap is in an inconsistent state.", (stderr));
+      Hproc9691940_return_value = 0;
+      goto Hproc969194_return;}}
+  else {
+    Hproc9691940_return_value = 1;
+    goto Hproc969194_return;}}
+ Hproc969194_return:
+  switch (Hproc969194_return_tag) {
+  case 0: goto Hproc969194_return_0;
+  case 1: goto Hproc969194_return_1;
+  default: goto Hproc969194_return_2;
+  }}
+
+}
+long s48_trace_locationsB(char * start_214X, char * end_215X)
+{
+  char * arg0K0;
+  char * arg0K1;
+  long arg1K0;
+  long new_232X;
+  char * data_addr_231X;
+  char * frontier_230X;
+  long new_thing_229X;
+  char * frontier_228X;
+  long new_thing_227X;
+  char * a_226X;
+  long descriptor_225X;
+  long h_224X;
+  char * a_223X;
+  char v_222X;
+  long type_221X;
+  char v_220X;
+  char * next_219X;
+  long thing_218X;
+  char * frontier_217X;
+  char * addr_216X;
+ {  arg0K0 = start_214X;
+  arg0K1 = (s48_ShpS);
+  goto L6441;}
+ L6441: {
+  addr_216X = arg0K0;
+  frontier_217X = arg0K1;
+  if ((addr_216X < end_215X)) {
+    thing_218X = *((long *) addr_216X);
+    next_219X = addr_216X + 4;
+    if ((2 == (3 & thing_218X))) {
+      if ((2 == (3 & thing_218X))) {
+        if (((31 & (((thing_218X)>>2))) < 16)) {
+          arg0K0 = next_219X;
+          arg0K1 = frontier_217X;
+          goto L6441;}
+        else {
+          arg0K0 = (next_219X + (-4 & (3 + ((long)(((unsigned long)thing_218X)>>8)))));
+          arg0K1 = frontier_217X;
+          goto L6441;}}
+      else {
+        arg0K0 = next_219X;
+        arg0K1 = frontier_217X;
+        goto L6441;}}
+    else {
+      if ((Swriting_imagePS)) {
+        v_220X = gc_recordP(thing_218X);
+        if (v_220X) {
+          type_221X = *((long *) (((char *) (-3 + thing_218X))));
+          v_222X = gc_recordP(type_221X);
+          if (v_222X) {
+            if ((1 == (*((long *) ((((char *) (-3 + type_221X))) + 4))))) {
+              note_undumpableB(thing_218X);
+              *((long *) addr_216X) = (*((long *) ((((char *) (-3 + thing_218X))) + 4)));
+              arg0K0 = addr_216X;
+              arg0K1 = frontier_217X;
+              goto L6441;}
+            else {
+              goto L6475;}}
+          else {
+            goto L6475;}}
+        else {
+          goto L6475;}}
+      else {
+        goto L6475;}}}
+  else {
+    s48_ShpS = frontier_217X;
+    return 0;}}
+ L6475: {
+  if ((3 == (3 & thing_218X))) {
+    a_223X = ((char *) (-3 + thing_218X));
+    if ((a_223X < (Sfrom_beginS))) {
+      arg0K0 = next_219X;
+      arg0K1 = frontier_217X;
+      goto L6441;}
+    else {
+      if ((a_223X < (Sfrom_endS))) {
+        h_224X = *((long *) ((((char *) (-3 + thing_218X))) + -4));
+        if ((3 == (3 & h_224X))) {
+          arg1K0 = h_224X;
+          arg0K1 = frontier_217X;
+          goto L6482;}
+        else {
+          if ((1074 == h_224X)) {
+            descriptor_225X = *((long *) (((char *) (-3 + thing_218X))));
+            if ((3 == (3 & descriptor_225X))) {
+              a_226X = ((char *) (-3 + descriptor_225X));
+              if ((a_226X < (Sfrom_beginS))) {
+                goto L7062;}
+              else {
+                if ((a_226X < (Sfrom_endS))) {
+                  new_thing_227X = copy_weak_pointer(thing_218X, frontier_217X, &frontier_228X);
+                  arg1K0 = new_thing_227X;
+                  arg0K1 = frontier_228X;
+                  goto L6482;}
+                else {
+                  goto L7062;}}}
+            else {
+              goto L7062;}}
+          else {
+            goto L7062;}}}
+      else {
+        arg0K0 = next_219X;
+        arg0K1 = frontier_217X;
+        goto L6441;}}}
+  else {
+    arg0K0 = next_219X;
+    arg0K1 = frontier_217X;
+    goto L6441;}}
+ L6482: {
+  new_thing_229X = arg1K0;
+  frontier_230X = arg0K1;
+  *((long *) addr_216X) = new_thing_229X;
+  arg0K0 = next_219X;
+  arg0K1 = frontier_230X;
+  goto L6441;}
+ L7062: {
+  *((long *) frontier_217X) = h_224X;
+  data_addr_231X = frontier_217X + 4;
+  new_232X = 3 + (((long) data_addr_231X));
+  *((long *) ((((char *) (-3 + thing_218X))) + -4)) = new_232X;
+  memcpy((void *)data_addr_231X, (void *)(((char *) (-3 + thing_218X))),((long)(((unsigned long)h_224X)>>8)));
+  arg1K0 = new_232X;
+  arg0K1 = (data_addr_231X + (-4 & (3 + ((long)(((unsigned long)h_224X)>>8)))));
+  goto L6482;}
+}
+void s48_do_gc(void)
+{
+  char * arg0K0;
+  char * end_234X;
+  char * start_233X;
+ {  arg0K0 = (Snewspace_beginS);
+  goto L6697;}
+ L6697: {
+  start_233X = arg0K0;
+  end_234X = s48_ShpS;
+  s48_trace_locationsB(start_233X, end_234X);
+  if (((((((s48_SlimitS) - (s48_ShpS)))>>2)) < 0)) {
+    ps_error("GC error: ran out of space in new heap", 0);
+    return clean_weak_pointers();}
+  else {
+    if ((end_234X < (s48_ShpS))) {
+      arg0K0 = end_234X;
+      goto L6697;}
+    else {
+      return clean_weak_pointers();}}}
+}
+long s48_trace_stob_contentsB(long stob_235X)
+{
+  char * start_237X;
+  long h_236X;
+ {  h_236X = *((long *) ((((char *) (-3 + stob_235X))) + -4));
+  start_237X = ((char *) (-3 + stob_235X));
+  return s48_trace_locationsB(start_237X, (start_237X + (-4 & (3 + ((long)(((unsigned long)h_236X)>>8))))));}
+}
+void s48_begin_collection(void)
+{
+  long arg1K0;
+  long i_245X;
+  long count_244X;
+  long *sizes_243X;
+  char * *areas_242X;
+  char * temp_241X;
+  char * temp_240X;
+  char * temp_239X;
+  char * temp_238X;
+ {  Sfrom_beginS = (Snewspace_beginS);
+  Sfrom_endS = (Snewspace_endS);
+  temp_238X = s48_SlimitS;
+  s48_SlimitS = (Soldspace_limitS);
+  Soldspace_limitS = temp_238X;
+  temp_239X = s48_ShpS;
+  s48_ShpS = (Soldspace_hpS);
+  Soldspace_hpS = temp_239X;
+  temp_240X = Snewspace_beginS;
+  Snewspace_beginS = (Soldspace_beginS);
+  Soldspace_beginS = temp_240X;
+  temp_241X = Snewspace_endS;
+  Snewspace_endS = (Soldspace_endS);
+  Soldspace_endS = temp_241X;
+  s48_ShpS = (Snewspace_beginS);
+  Sweak_pointer_hpS = NULL;
+  Swriting_imagePS = 0;
+  if ((0 < (Simpure_area_countS))) {
+    areas_242X = Simpure_areasS;
+    sizes_243X = Simpure_sizesS;
+    count_244X = Simpure_area_countS;
+    arg1K0 = 0;
+    goto L6812;}
+  else {
+    return;}}
+ L6812: {
+  i_245X = arg1K0;
+  if ((i_245X < count_244X)) {
+    s48_trace_locationsB((*(areas_242X + i_245X)), ((*(areas_242X + i_245X)) + (*(sizes_243X + i_245X))));
+    arg1K0 = (1 + i_245X);
+    goto L6812;}
+  else {
+    return;}}
+}
+long s48_trace_value(long stob_246X)
+{
+  char * arg0K1;
+  long arg1K0;
+  long new_261X;
+  char * data_addr_260X;
+  char * new_hp_259X;
+  long new_thing_258X;
+  char * new_hp_257X;
+  long new_thing_256X;
+  char * a_255X;
+  long descriptor_254X;
+  long h_253X;
+  char * frontier_252X;
+  char * a_251X;
+  char v_250X;
+  long type_249X;
+  char v_248X;
+  long stob_247X;
+ {  arg1K0 = stob_247X;
+  goto L7253;}
+ L7253: {
+  stob_247X = arg1K0;
+  if ((Swriting_imagePS)) {
+    v_248X = gc_recordP(stob_246X);
+    if (v_248X) {
+      type_249X = *((long *) (((char *) (-3 + stob_246X))));
+      v_250X = gc_recordP(type_249X);
+      if (v_250X) {
+        if ((1 == (*((long *) ((((char *) (-3 + type_249X))) + 4))))) {
+          note_undumpableB(stob_246X);
+          arg1K0 = (*((long *) ((((char *) (-3 + stob_246X))) + 4)));
+          goto L7253;}
+        else {
+          goto L6840;}}
+      else {
+        goto L6840;}}
+    else {
+      goto L6840;}}
+  else {
+    goto L6840;}}
+ L6840: {
+  if ((3 == (3 & stob_246X))) {
+    a_251X = ((char *) (-3 + stob_246X));
+    if ((a_251X < (Sfrom_beginS))) {
+      return stob_246X;}
+    else {
+      if ((a_251X < (Sfrom_endS))) {
+        frontier_252X = s48_ShpS;
+        h_253X = *((long *) ((((char *) (-3 + stob_246X))) + -4));
+        if ((3 == (3 & h_253X))) {
+          arg1K0 = h_253X;
+          arg0K1 = frontier_252X;
+          goto L6862;}
+        else {
+          if ((1074 == h_253X)) {
+            descriptor_254X = *((long *) (((char *) (-3 + stob_246X))));
+            if ((3 == (3 & descriptor_254X))) {
+              a_255X = ((char *) (-3 + descriptor_254X));
+              if ((a_255X < (Sfrom_beginS))) {
+                goto L4193;}
+              else {
+                if ((a_255X < (Sfrom_endS))) {
+                  new_thing_256X = copy_weak_pointer(stob_246X, frontier_252X, &new_hp_257X);
+                  arg1K0 = new_thing_256X;
+                  arg0K1 = new_hp_257X;
+                  goto L6862;}
+                else {
+                  goto L4193;}}}
+            else {
+              goto L4193;}}
+          else {
+            goto L4193;}}}
+      else {
+        return stob_246X;}}}
+  else {
+    return stob_246X;}}
+ L6862: {
+  new_thing_258X = arg1K0;
+  new_hp_259X = arg0K1;
+  s48_ShpS = new_hp_259X;
+  return new_thing_258X;}
+ L4193: {
+  *((long *) frontier_252X) = h_253X;
+  data_addr_260X = frontier_252X + 4;
+  new_261X = 3 + (((long) data_addr_260X));
+  *((long *) ((((char *) (-3 + stob_246X))) + -4)) = new_261X;
+  memcpy((void *)data_addr_260X, (void *)(((char *) (-3 + stob_246X))),((long)(((unsigned long)h_253X)>>8)));
+  arg1K0 = new_261X;
+  arg0K1 = (data_addr_260X + (-4 & (3 + ((long)(((unsigned long)h_253X)>>8)))));
+  goto L6862;}
+}
+long s48_write_image(long resume_proc_262X, FILE * port_263X)
+{
+  char * arg0K0;
+  long arg1K0;
+  char * merged_arg0K1;
+  char * merged_arg0K0;
+
+  int abort_collection_return_tag;
+  int Hproc967264_return_tag;
+  char Hproc9672640_return_value;
+  char * start_265X;
+  char * end_266X;
+  long h_320X;
+  long h_319X;
+  long d_318X;
+  char * addr_317X;
+  char * temp_316X;
+  char * temp_315X;
+  char * temp_314X;
+  char * temp_313X;
+  long type_312X;
+  long obj_311X;
+  char * next_310X;
+  long d_309X;
+  char * addr_308X;
+  long type_307X;
+  long status_306X;
+  long v_305X;
+  long v_304X;
+  long v_303X;
+  long v_302X;
+  long v_301X;
+  long v_300X;
+  long v_299X;
+  char * v_298X;
+  long v_297X;
+  char * v_296X;
+  long v_295X;
+  long v_294X;
+  long v_293X;
+  long v_292X;
+  long v_291X;
+  long imported_bindings_290X;
+  long resumer_records_289X;
+  char v_288X;
+  long i_287X;
+  long count_286X;
+  long *sizes_285X;
+  char * *areas_284X;
+  char v_283X;
+  long i_282X;
+  long count_281X;
+  long *sizes_280X;
+  char * *areas_279X;
+  char v_278X;
+  char * start_hp_277X;
+  long symbols_276X;
+  char * end_275X;
+  char * start_274X;
+  long resume_proc_273X;
+  long exported_bindings_272X;
+  long v_271X;
+  char * temp_270X;
+  char * temp_269X;
+  char * temp_268X;
+  char * temp_267X;
+ {  Sfrom_beginS = (Snewspace_beginS);
+  Sfrom_endS = (Snewspace_endS);
+  temp_267X = s48_SlimitS;
+  s48_SlimitS = (Soldspace_limitS);
+  Soldspace_limitS = temp_267X;
+  temp_268X = s48_ShpS;
+  s48_ShpS = (Soldspace_hpS);
+  Soldspace_hpS = temp_268X;
+  temp_269X = Snewspace_beginS;
+  Snewspace_beginS = (Soldspace_beginS);
+  Soldspace_beginS = temp_269X;
+  temp_270X = Snewspace_endS;
+  Snewspace_endS = (Soldspace_endS);
+  Soldspace_endS = temp_270X;
+  s48_ShpS = (Snewspace_beginS);
+  Sweak_pointer_hpS = NULL;
+  Swriting_imagePS = 1;
+  Sundumpable_recordsS = 25;
+  Sundumpable_countS = 0;
+  v_271X = s48_exported_bindings();
+  exported_bindings_272X = s48_trace_value(v_271X);
+  resume_proc_273X = s48_trace_value(resume_proc_262X);
+  arg0K0 = (Snewspace_beginS);
+  goto L6983;}
+ L6983: {
+  start_274X = arg0K0;
+  end_275X = s48_ShpS;
+  s48_trace_locationsB(start_274X, end_275X);
+  if (((((((s48_SlimitS) - (s48_ShpS)))>>2)) < 0)) {
+    ps_error("GC error: ran out of space in new heap", 0);
+    clean_weak_pointers();
+    goto L6952;}
+  else {
+    if ((end_275X < (s48_ShpS))) {
+      arg0K0 = end_275X;
+      goto L6983;}
+    else {
+      clean_weak_pointers();
+      goto L6952;}}}
+ L6952: {
+  s48_mark_traced_channels_closedB();
+  symbols_276X = s48_copy_symbol_table();
+  Sfinding_typeS = 8;
+  start_hp_277X = s48_ShpS;
+  *((long *) (s48_ShpS)) = 0;
+  s48_ShpS = ((s48_ShpS) + 4);
+  merged_arg0K0 = (Snewspace_beginS);
+  merged_arg0K1 = start_hp_277X;
+  Hproc967264_return_tag = 0;
+  goto Hproc967264;
+ Hproc967264_return_0:
+  v_278X = Hproc9672640_return_value;
+  if (v_278X) {
+    if ((0 < (Simpure_area_countS))) {
+      areas_279X = Simpure_areasS;
+      sizes_280X = Simpure_sizesS;
+      count_281X = Simpure_area_countS;
+      arg1K0 = 0;
+      goto L5907;}
+    else {
+      goto L5847;}}
+  else {
+    goto L5865;}}
+ L5907: {
+  i_282X = arg1K0;
+  if ((i_282X < count_281X)) {
+    merged_arg0K0 = (*(areas_279X + i_282X));
+    merged_arg0K1 = ((*(areas_279X + i_282X)) + (*(sizes_280X + i_282X)));
+    Hproc967264_return_tag = 1;
+    goto Hproc967264;
+   Hproc967264_return_1:
+    v_283X = Hproc9672640_return_value;
+    if (v_283X) {
+      arg1K0 = (1 + i_282X);
+      goto L5907;}
+    else {
+      goto L5865;}}
+  else {
+    goto L5847;}}
+ L5847: {
+  if ((0 < (Spure_area_countS))) {
+    areas_284X = Spure_areasS;
+    sizes_285X = Spure_sizesS;
+    count_286X = Spure_area_countS;
+    arg1K0 = 0;
+    goto L5928;}
+  else {
+    goto L5854;}}
+ L5865: {
+  s48_ShpS = start_hp_277X;
+  arg1K0 = 1;
+  goto L7002;}
+ L5928: {
+  i_287X = arg1K0;
+  if ((i_287X < count_286X)) {
+    merged_arg0K0 = (*(areas_284X + i_287X));
+    merged_arg0K1 = ((*(areas_284X + i_287X)) + (*(sizes_285X + i_287X)));
+    Hproc967264_return_tag = 2;
+    goto Hproc967264;
+   Hproc967264_return_2:
+    v_288X = Hproc9672640_return_value;
+    if (v_288X) {
+      arg1K0 = (1 + i_287X);
+      goto L5928;}
+    else {
+      goto L5865;}}
+  else {
+    goto L5854;}}
+ L5854: {
+  *((long *) start_hp_277X) = (10 + (((((s48_ShpS) - (start_hp_277X + 4)))<<8)));
+  arg1K0 = (3 + (((long) (start_hp_277X + 4))));
+  goto L7002;}
+ L7002: {
+  resumer_records_289X = arg1K0;
+  imported_bindings_290X = s48_cleaned_imported_bindings();
+  if ((1 == resumer_records_289X)) {
+    abort_collection_return_tag = 0;
+    goto abort_collection;
+   abort_collection_return_0:
+    return ENOMEM;}
+  else {
+    SstatusS = NO_ERRORS;
+    if (((SstatusS) == NO_ERRORS)) {
+      PS_WRITE_CHAR(10, port_263X, v_291X)
+      SstatusS = v_291X;
+      goto L2019;}
+    else {
+      goto L2019;}}}
+ L2019: {
+  if (((SstatusS) == NO_ERRORS)) {
+    PS_WRITE_CHAR(12, port_263X, v_292X)
+    SstatusS = v_292X;
+    goto L2028;}
+  else {
+    goto L2028;}}
+ L2028: {
+  if (((SstatusS) == NO_ERRORS)) {
+    PS_WRITE_CHAR(10, port_263X, v_293X)
+    SstatusS = v_293X;
+    goto L2037;}
+  else {
+    goto L2037;}}
+ L2037: {
+  if (((SstatusS) == NO_ERRORS)) {
+    SstatusS = (ps_write_string("Vanilla 20", port_263X));
+    goto L2044;}
+  else {
+    goto L2044;}}
+ L2044: {
+  if (((SstatusS) == NO_ERRORS)) {
+    PS_WRITE_CHAR(10, port_263X, v_294X)
+    SstatusS = v_294X;
+    goto L2053;}
+  else {
+    goto L2053;}}
+ L2053: {
+  if (((SstatusS) == NO_ERRORS)) {
+    SstatusS = (ps_write_integer(4, port_263X));
+    goto L2123;}
+  else {
+    goto L2123;}}
+ L2123: {
+  if (((SstatusS) == NO_ERRORS)) {
+    PS_WRITE_CHAR(10, port_263X, v_295X)
+    SstatusS = v_295X;
+    goto L2055;}
+  else {
+    goto L2055;}}
+ L2055: {
+  v_296X = Snewspace_beginS;
+  if (((SstatusS) == NO_ERRORS)) {
+    SstatusS = (ps_write_integer(((((((long) v_296X)))>>2)), port_263X));
+    goto L2143;}
+  else {
+    goto L2143;}}
+ L2143: {
+  if (((SstatusS) == NO_ERRORS)) {
+    PS_WRITE_CHAR(10, port_263X, v_297X)
+    SstatusS = v_297X;
+    goto L2061;}
+  else {
+    goto L2061;}}
+ L2061: {
+  v_298X = s48_ShpS;
+  if (((SstatusS) == NO_ERRORS)) {
+    SstatusS = (ps_write_integer(((((((long) v_298X)))>>2)), port_263X));
+    goto L2163;}
+  else {
+    goto L2163;}}
+ L2163: {
+  if (((SstatusS) == NO_ERRORS)) {
+    PS_WRITE_CHAR(10, port_263X, v_299X)
+    SstatusS = v_299X;
+    goto L2067;}
+  else {
+    goto L2067;}}
+ L2067: {
+  if (((SstatusS) == NO_ERRORS)) {
+    SstatusS = (ps_write_integer(symbols_276X, port_263X));
+    goto L2178;}
+  else {
+    goto L2178;}}
+ L2178: {
+  if (((SstatusS) == NO_ERRORS)) {
+    PS_WRITE_CHAR(10, port_263X, v_300X)
+    SstatusS = v_300X;
+    goto L2069;}
+  else {
+    goto L2069;}}
+ L2069: {
+  if (((SstatusS) == NO_ERRORS)) {
+    SstatusS = (ps_write_integer(imported_bindings_290X, port_263X));
+    goto L2193;}
+  else {
+    goto L2193;}}
+ L2193: {
+  if (((SstatusS) == NO_ERRORS)) {
+    PS_WRITE_CHAR(10, port_263X, v_301X)
+    SstatusS = v_301X;
+    goto L2071;}
+  else {
+    goto L2071;}}
+ L2071: {
+  if (((SstatusS) == NO_ERRORS)) {
+    SstatusS = (ps_write_integer(exported_bindings_272X, port_263X));
+    goto L2208;}
+  else {
+    goto L2208;}}
+ L2208: {
+  if (((SstatusS) == NO_ERRORS)) {
+    PS_WRITE_CHAR(10, port_263X, v_302X)
+    SstatusS = v_302X;
+    goto L2073;}
+  else {
+    goto L2073;}}
+ L2073: {
+  if (((SstatusS) == NO_ERRORS)) {
+    SstatusS = (ps_write_integer(resumer_records_289X, port_263X));
+    goto L2223;}
+  else {
+    goto L2223;}}
+ L2223: {
+  if (((SstatusS) == NO_ERRORS)) {
+    PS_WRITE_CHAR(10, port_263X, v_303X)
+    SstatusS = v_303X;
+    goto L2075;}
+  else {
+    goto L2075;}}
+ L2075: {
+  if (((SstatusS) == NO_ERRORS)) {
+    SstatusS = (ps_write_integer(resume_proc_273X, port_263X));
+    goto L2238;}
+  else {
+    goto L2238;}}
+ L2238: {
+  if (((SstatusS) == NO_ERRORS)) {
+    PS_WRITE_CHAR(10, port_263X, v_304X)
+    SstatusS = v_304X;
+    goto L2077;}
+  else {
+    goto L2077;}}
+ L2077: {
+  if (((SstatusS) == NO_ERRORS)) {
+    PS_WRITE_CHAR(12, port_263X, v_305X)
+    SstatusS = v_305X;
+    goto L2086;}
+  else {
+    goto L2086;}}
+ L2086: {
+  *((long *) (s48_ShpS)) = 1;
+  if (((SstatusS) == NO_ERRORS)) {
+    SstatusS = (ps_write_block(port_263X, ((char *) (s48_ShpS)), (((s48_ShpS) + 4) - (s48_ShpS))));
+    goto L2105;}
+  else {
+    goto L2105;}}
+ L2105: {
+  if (((SstatusS) == NO_ERRORS)) {
+    SstatusS = (ps_write_block(port_263X, ((char *) (Snewspace_beginS)), ((s48_ShpS) - (Snewspace_beginS))));
+    goto L2118;}
+  else {
+    goto L2118;}}
+ L2118: {
+  status_306X = SstatusS;
+  abort_collection_return_tag = 1;
+  goto abort_collection;
+ abort_collection_return_1:
+  return status_306X;}
+ Hproc967264: {
+  start_265X = merged_arg0K0;
+  end_266X = merged_arg0K1;{
+  type_307X = Sfinding_typeS;
+  arg0K0 = start_265X;
+  goto L4852;}
+ L4852: {
+  addr_308X = arg0K0;
+  if ((addr_308X < end_266X)) {
+    d_309X = *((long *) addr_308X);
+    next_310X = addr_308X + (4 + (-4 & (3 + ((long)(((unsigned long)d_309X)>>8)))));
+    if ((2 == (3 & d_309X))) {
+      if ((type_307X == (31 & (((d_309X)>>2))))) {
+        obj_311X = 3 + (((long) (addr_308X + 4)));
+        type_312X = *((long *) (((char *) (-3 + obj_311X))));
+        if ((3 == (3 & type_312X))) {
+          if ((8 == (31 & ((((*((long *) ((((char *) (-3 + type_312X))) + -4))))>>2))))) {
+            if ((3 == (3 & (*((long *) ((((char *) (-3 + type_312X))) + 4)))))) {
+              if ((((s48_ShpS) + 16) < (s48_SlimitS))) {
+                *((long *) (s48_ShpS)) = obj_311X;
+                s48_ShpS = ((s48_ShpS) + 4);
+                arg0K0 = next_310X;
+                goto L4852;}
+              else {
+                Hproc9672640_return_value = 0;
+                goto Hproc967264_return;}}
+            else {
+              arg0K0 = next_310X;
+              goto L4852;}}
+          else {
+            arg0K0 = next_310X;
+            goto L4852;}}
+        else {
+          arg0K0 = next_310X;
+          goto L4852;}}
+      else {
+        arg0K0 = next_310X;
+        goto L4852;}}
+    else {
+      ps_write_string("heap is in an inconsistent state.", (stderr));
+      Hproc9672640_return_value = 0;
+      goto Hproc967264_return;}}
+  else {
+    Hproc9672640_return_value = 1;
+    goto Hproc967264_return;}}
+ Hproc967264_return:
+  switch (Hproc967264_return_tag) {
+  case 0: goto Hproc967264_return_0;
+  case 1: goto Hproc967264_return_1;
+  default: goto Hproc967264_return_2;
+  }}
+
+ abort_collection: {
+{ temp_313X = s48_SlimitS;
+  s48_SlimitS = (Soldspace_limitS);
+  Soldspace_limitS = temp_313X;
+  temp_314X = s48_ShpS;
+  s48_ShpS = (Soldspace_hpS);
+  Soldspace_hpS = temp_314X;
+  temp_315X = Snewspace_beginS;
+  Snewspace_beginS = (Soldspace_beginS);
+  Soldspace_beginS = temp_315X;
+  temp_316X = Snewspace_endS;
+  Snewspace_endS = (Soldspace_endS);
+  Soldspace_endS = temp_316X;
+  arg0K0 = (Snewspace_beginS);
+  goto L4085;}
+ L4085: {
+  addr_317X = arg0K0;
+  if ((addr_317X < (s48_ShpS))) {
+    d_318X = *((long *) addr_317X);
+    if ((2 == (3 & d_318X))) {
+      arg1K0 = d_318X;
+      goto L4106;}
+    else {
+      h_319X = *((long *) ((((char *) (-3 + d_318X))) + -4));
+      *((long *) addr_317X) = h_319X;
+      arg1K0 = h_319X;
+      goto L4106;}}
+  else {
+    goto abort_collection_return;}}
+ L4106: {
+  h_320X = arg1K0;
+  arg0K0 = (addr_317X + (4 + (-4 & (3 + ((long)(((unsigned long)h_320X)>>8))))));
+  goto L4085;}
+ abort_collection_return:
+  switch (abort_collection_return_tag) {
+  case 0: goto abort_collection_return_0;
+  default: goto abort_collection_return_1;
+  }}
+
+}
+void s48_initializing_gc_root(void)
+{
+  long v_325X;
+  long v_324X;
+  long v_323X;
+  long v_322X;
+  long v_321X;
+ {  if ((SinitializingPS)) {
+    v_321X = s48_trace_value((Sstartup_procedureS));
+    Sstartup_procedureS = v_321X;
+    v_322X = s48_trace_value((SsymbolsS));
+    SsymbolsS = v_322X;
+    v_323X = s48_trace_value((Simported_bindingsS));
+    Simported_bindingsS = v_323X;
+    v_324X = s48_trace_value((Sexported_bindingsS));
+    Sexported_bindingsS = v_324X;
+    v_325X = s48_trace_value((Sresumer_recordsS));
+    Sresumer_recordsS = v_325X;
+    return;}
+  else {
+    return;}}
+}void
+s48_heap_init(void)
+{
+Spure_area_countS = 0;
+Simpure_area_countS = 0;
+Sfinding_typeS = 1;
+Sgc_countS = 0;
+SstatusS = NO_ERRORS;
+SeofPS = 0;
+SinitializingPS = 1;
+Hthe_record_type9260 = 1;
+}
diff --git a/c/scheme48heap.h b/c/scheme48heap.h
new file mode 100644
index 0000000..7072653
--- /dev/null
+++ b/c/scheme48heap.h
@@ -0,0 +1,53 @@
+/*
+ * Externally visible objects defined in scheme48heap.c.
+ */
+
+/* initialize top-level variables */
+extern void	s48_heap_init(void);
+
+/* heap-init interface */
+extern void	s48_initialize_heap(long, long);
+extern void	s48_register_static_areas(unsigned char, long *, long *,
+					  unsigned char, long *, long *);
+
+/* heap interface */
+extern long	s48_available(void);
+extern long	s48_heap_size(void);
+extern long	s48_find_all(long);
+extern long	s48_find_all_records(long);
+extern char	*s48_ShpS;
+extern char	*s48_SlimitS;
+
+/* gc interface */
+extern void	s48_begin_collection(void);
+extern long	s48_trace_value(long);
+extern long	s48_trace_locationsB(char *, char *);
+extern long	s48_trace_stob_contentsB(long);
+extern void	s48_do_gc(void);
+extern void	s48_end_collection(void);
+extern char	s48_extantP(long);
+extern long	s48_gc_count(void);
+
+/* allocation interface */
+extern char	s48_availableP(long);
+extern long	s48_preallocate_space(long);
+extern char	*s48_allocate_space(long, long, long);
+extern void	s48_write_barrier(long, char *, long);
+
+/* images interface */
+extern char	s48_image_writing_okayP(void);
+extern long	s48_write_image(long, FILE *);
+extern long	s48_check_image_header(unsigned char *);
+extern long	s48_read_image();
+
+extern long	s48_startup_procedure(void);
+extern long	s48_initial_symbols(void);
+extern long	s48_initial_imported_bindings(void);
+extern long	s48_initial_exported_bindings(void);
+extern long	s48_resumer_records(void);
+extern long	s48_undumpable_records(long *);
+
+extern void	s48_initialization_completeB(void);
+extern void	s48_initializing_gc_root(void);
+
+extern void     s48_set_image_valuesB(long, long, long, long);
diff --git a/c/scheme48vm-prelude.h b/c/scheme48vm-prelude.h
new file mode 100644
index 0000000..ee622b1
--- /dev/null
+++ b/c/scheme48vm-prelude.h
@@ -0,0 +1,41 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include "c-mods.h"
+#include "write-barrier.h"
+
+#define SMALL_MULTIPLY(x,y) ((x) * (y))
+
+#define	NO_ERRORS	0		/* extension to errno.h */
+
+#include "scheme48vm.h"
+#include "scheme48heap.h"
+#include "event.h"
+#include "fd-io.h"
+
+extern s48_value	s48_extended_vm(long, s48_value),
+			s48_lookup_external_name(char *, char *),
+			s48_external_call(s48_value proc,
+					  s48_value proc_name,
+					  long nargs,
+					  char *argv);
+/*
+ * The following are hand-written macro versions of procedures
+ * in scheme48heap.c.
+ */
+
+#define	AVAILABLEp(cells)	(s48_ShpS + ((cells)<<2) < s48_SlimitS)
+
+static char	*_HHallocate_temp;
+
+#define	ALLOCATE_SPACE(type, len)		\
+		(_HHallocate_temp = s48_ShpS,	\
+			s48_ShpS += ((len)+3) & ~3,	\
+			_HHallocate_temp)
+
+/*
+ * We rename these to avoid name clashes.
+ */
+#define TTreturn_value		s48_return_value
+#define TTrun_machine(x)	s48_run_machine(x)
+     
diff --git a/c/scheme48vm.c b/c/scheme48vm.c
new file mode 100644
index 0000000..bf7c338
--- /dev/null
+++ b/c/scheme48vm.c
@@ -0,0 +1,10513 @@
+#include <stdio.h>
+#include "prescheme.h"
+#include "scheme48vm-prelude.h"
+
+static char add_more_channels(long);
+static void enqueue_channelB(long, long);
+static long close_channelB(long);
+static void push_continuationB(char *, long);
+static long enter_string(char*, long);
+static char HcleanerB2160(long);
+static void push_exception_continuationB(long, long);
+static long make_registered_channel(long, long, long, long, long*);
+static long channel_close_error(long, long, long);
+static void HtopD8861(void);
+static long Hlookup2102(long, long, long);
+static long Hlookup2083(long, long, long);
+static void HtopD8854(void);
+static long collect_saving_temps(long, long, long*);
+void s48_set_extension_valueB(long);
+void s48_note_event(void);
+void s48_set_os_signal(long, long);
+long s48_exported_bindings(void);
+char * s48_set_gc_roots_baseB(void);
+char s48_release_gc_roots_baseB(char *);
+void s48_disable_interruptsB(void);
+void s48_push_gc_rootsB(char *, long);
+void s48_register_gc_rootB(char *);
+void s48_stack_setB(long, long);
+long s48_stack_ref(long);
+void s48_push(long);
+long s48_resetup_external_exception(long, long);
+void s48_enable_interruptsB(void);
+char s48_pop_gc_rootsB(void);
+void s48_mark_traced_channels_closedB(void);
+long s48_set_channel_os_index(long, long);
+long s48_cleaned_imported_bindings(void);
+long s48_copy_symbol_table(void);
+void s48_setup_external_exception(long, long);
+void s48_close_channel(long);
+char s48_warn_about_undefined_imported_bindings(void);
+void s48_define_exported_binding(char*, long);
+long s48_add_channel(long, long, long);
+long s48_get_imported_binding(char*);
+long s48_allocate_stob(long, long);
+void s48_initialize_vm(char *, long);
+long s48_restart(long, long);
+long s48_call_startup_procedure(char**, long);
+static long Snumber_of_channelsS;
+static long *Svm_channelsS;
+static long Spending_channels_headS;
+static long Spending_channels_tailS;
+static char * Sstack_beginS;
+static char * Sstack_endS;
+static char * SstackS;
+static char * Sstack_limitS;
+static long ScontS;
+static long Sbottom_of_stackS;
+static char Sstack_warningPS;
+static long SenvS;
+static long StemplateS;
+static char * Scode_pointerS;
+static long SvalS;
+static long Sexception_handlersS;
+static long Sinterrupt_handlersS;
+static long Scurrent_threadS;
+static long Ssession_dataS;
+static long Sfinalizer_alistS;
+static long Sfinalize_theseS;
+static long Senabled_interruptsS;
+static long Spending_interruptsS;
+static long Sinterrupted_templateS;
+static long Sinterrupt_templateS;
+static long Sexception_templateS;
+static long Ssaved_pcS;
+static long Slosing_opcodeS;
+static long Sos_signal_typeS;
+static long Sos_signal_argumentS;
+static char Sexternal_exceptionPS;
+static long Sexternal_exception_nargsS;
+static long Simported_bindingsS;
+static long Sexported_bindingsS;
+static long Sthe_symbol_tableS;
+static char * Sexternal_root_stackS;
+static char * Sexternal_root_stack_baseS;
+static char * Spermanent_external_rootsS;
+static void (*Sgc_root_procS)(void);
+static void (*Spost_gc_cleanupS)(void);
+char s48_Spending_interruptPS;
+long s48_Sextension_valueS;
+long s48_Scallback_return_stack_blockS;
+char s48_Spending_eventsPS;
+
+static char add_more_channels(long index_5X)
+{
+  long arg0K0;
+  long i_11X;
+  long i_10X;
+  long *new_vm_channels_9X;
+  long new_count_8X;
+  long y_7X;
+  long x_6X;
+ {  x_6X = 1 + index_5X;
+  y_7X = 8 + (Snumber_of_channelsS);
+  if ((x_6X < y_7X)) {
+    arg0K0 = y_7X;
+    goto L2366;}
+  else {
+    arg0K0 = x_6X;
+    goto L2366;}}
+ L2366: {
+  new_count_8X = arg0K0;
+  new_vm_channels_9X = (long*)malloc(sizeof(long) * new_count_8X);
+  if ((NULL == new_vm_channels_9X)) {
+    return 0;}
+  else {
+    arg0K0 = 0;
+    goto L2378;}}
+ L2378: {
+  i_10X = arg0K0;
+  if ((i_10X == (Snumber_of_channelsS))) {
+    arg0K0 = (Snumber_of_channelsS);
+    goto L2393;}
+  else {
+    *(new_vm_channels_9X + i_10X) = (*((Svm_channelsS) + i_10X));
+    arg0K0 = (1 + i_10X);
+    goto L2378;}}
+ L2393: {
+  i_11X = arg0K0;
+  if ((i_11X == new_count_8X)) {
+    free((Svm_channelsS));
+    Svm_channelsS = new_vm_channels_9X;
+    Snumber_of_channelsS = new_count_8X;
+    return 1;}
+  else {
+    *(new_vm_channels_9X + i_11X) = 1;
+    arg0K0 = (1 + i_11X);
+    goto L2393;}}
+}
+static void enqueue_channelB(long index_12X, long status_13X)
+{
+  char * addr_18X;
+  long x_17X;
+  char * addr_16X;
+  long val_15X;
+  long channel_14X;
+ {  channel_14X = *((Svm_channelsS) + index_12X);
+  val_15X = ((status_13X)<<2);
+  addr_16X = (((char *) (-3 + channel_14X))) + 16;
+  S48_WRITE_BARRIER(channel_14X, addr_16X, val_15X);
+  *((long *) addr_16X) = val_15X;
+  if ((1 == (*((long *) ((((char *) (-3 + channel_14X))) + 12))))) {
+    if ((1 == (Spending_channels_headS))) {
+      Spending_channels_headS = channel_14X;
+      Spending_channels_tailS = channel_14X;
+      return;}
+    else {
+      x_17X = Spending_channels_tailS;
+      addr_18X = (((char *) (-3 + x_17X))) + 12;
+      S48_WRITE_BARRIER(x_17X, addr_18X, channel_14X);
+      *((long *) addr_18X) = channel_14X;
+      Spending_channels_tailS = channel_14X;
+      return;}}
+  else {
+    return;}}
+}
+static long close_channelB(long channel_19X)
+{
+  long arg0K0;
+  char * addr_27X;
+  long status_26X;
+  long v_25X;
+  long v_24X;
+  long v_23X;
+  long v_22X;
+  long x_21X;
+  long os_index_20X;
+ {  os_index_20X = (((*((long *) ((((char *) (-3 + channel_19X))) + 8))))>>2);
+  x_21X = *((long *) ((((char *) (-3 + channel_19X))) + 16));
+  if ((5 == x_21X)) {
+    v_22X = ps_abort_fd_op(os_index_20X);
+    enqueue_channelB(os_index_20X, v_22X);
+    goto L7996;}
+  else {
+    goto L7996;}}
+ L7996: {
+  v_23X = *((long *) (((char *) (-3 + channel_19X))));
+  if ((4 == v_23X)) {
+    goto L8011;}
+  else {
+    if ((12 == (*((long *) (((char *) (-3 + channel_19X))))))) {
+      goto L8011;}
+    else {
+      v_24X = ps_close_fd(os_index_20X);
+      arg0K0 = v_24X;
+      goto L8018;}}}
+ L8011: {
+  v_25X = ps_close_fd(os_index_20X);
+  arg0K0 = v_25X;
+  goto L8018;}
+ L8018: {
+  status_26X = arg0K0;
+  *((Svm_channelsS) + os_index_20X) = 1;
+  addr_27X = ((char *) (-3 + channel_19X));
+  S48_WRITE_BARRIER(channel_19X, addr_27X, 0);
+  *((long *) addr_27X) = 0;
+  return status_26X;}
+}
+static void push_continuationB(char * code_pointer_28X, long size_29X)
+{
+  long cont_32X;
+  long template_31X;
+  long pc_30X;
+ {  pc_30X = (((code_pointer_28X - (((char *) (-3 + (*((long *) (((char *) (-3 + (StemplateS)))))))))))<<2);
+  template_31X = StemplateS;
+  SstackS = ((SstackS) + -20);
+  *((long *) ((SstackS) + 4)) = (128 | (4134 + (((size_29X)<<10))));
+  cont_32X = 3 + (((long) ((SstackS) + 8)));
+  *((long *) ((((char *) (-3 + cont_32X))) + 4)) = pc_30X;
+  *((long *) ((((char *) (-3 + cont_32X))) + 8)) = template_31X;
+  *((long *) ((((char *) (-3 + cont_32X))) + 12)) = (SenvS);
+  *((long *) (((char *) (-3 + cont_32X)))) = (ScontS);
+  ScontS = cont_32X;
+  return;}
+}
+static long enter_string(char *string_33X, long key_34X)
+{
+  long arg0K0;
+  long i_39X;
+  long string_38X;
+  char * addr_37X;
+  long len_36X;
+  long z_35X;
+ {  z_35X = strlen((char *) string_33X);
+  len_36X = 1 + z_35X;
+  addr_37X = ALLOCATE_SPACE(16, (4 + len_36X));
+  *((long *) addr_37X) = (66 + (((len_36X)<<8)));
+  string_38X = 3 + (((long) (addr_37X + 4)));
+  *((unsigned char *) ((((char *) (-3 + string_38X))) + z_35X)) = 0;
+  arg0K0 = 0;
+  goto L9526;}
+ L9526: {
+  i_39X = arg0K0;
+  if ((i_39X < z_35X)) {
+    *((unsigned char *) ((((char *) (-3 + string_38X))) + i_39X)) = ((*(string_33X + i_39X)));
+    arg0K0 = (1 + i_39X);
+    goto L9526;}
+  else {
+    return string_38X;}}
+}
+static char HcleanerB2160(long table_40X)
+{
+  long arg0K1;
+  long arg0K0;
+  long v_51X;
+  char * addr_50X;
+  long new_foo_49X;
+  char v_48X;
+  char * addr_47X;
+  long okay_46X;
+  long foo_45X;
+  long foo_44X;
+  char temp_43X;
+  long i_42X;
+  long table_41X;
+ {  table_41X = s48_trace_value(table_40X);
+  arg0K0 = 0;
+  goto L9716;}
+ L9716: {
+  i_42X = arg0K0;
+  temp_43X = 1024 == i_42X;
+  if (temp_43X) {
+    return temp_43X;}
+  else {
+    foo_44X = *((long *) ((((char *) (-3 + table_41X))) + (((i_42X)<<2))));
+    arg0K0 = foo_44X;
+    arg0K1 = 1;
+    goto L9736;}}
+ L9736: {
+  foo_45X = arg0K0;
+  okay_46X = arg0K1;
+  if ((1 == foo_45X)) {
+    addr_47X = (((char *) (-3 + table_41X))) + (((i_42X)<<2));
+    S48_WRITE_BARRIER(table_41X, addr_47X, okay_46X);
+    *((long *) addr_47X) = okay_46X;
+    arg0K0 = (1 + i_42X);
+    goto L9716;}
+  else {
+    v_48X = s48_extantP(foo_45X);
+    if (v_48X) {
+      new_foo_49X = s48_trace_value(foo_45X);
+      addr_50X = (((char *) (-3 + new_foo_49X))) + 4;
+      S48_WRITE_BARRIER(new_foo_49X, addr_50X, okay_46X);
+      *((long *) addr_50X) = okay_46X;
+      arg0K0 = new_foo_49X;
+      goto L9741;}
+    else {
+      arg0K0 = okay_46X;
+      goto L9741;}}}
+ L9741: {
+  v_51X = arg0K0;
+  arg0K0 = (*((long *) ((((char *) (-3 + foo_45X))) + 4)));
+  arg0K1 = v_51X;
+  goto L9736;}
+}
+static void push_exception_continuationB(long exception_52X, long instruction_size_53X)
+{
+  char * arg1K0;
+  long arg0K1;
+  long arg0K0;
+  long v_58X;
+  long i_57X;
+  char * p_56X;
+  long tem_55X;
+  long opcode_54X;
+ {  opcode_54X = *((unsigned char *) (Scode_pointerS));
+  *((long *) (SstackS)) = (((instruction_size_53X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((exception_52X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (StemplateS);
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((((Scode_pointerS) - (((char *) (-3 + (*((long *) (((char *) (-3 + (StemplateS)))))))))))<<2));
+  SstackS = ((SstackS) + -4);
+  tem_55X = Sexception_templateS;
+  StemplateS = tem_55X;
+  Scode_pointerS = (((char *) (-3 + (*((long *) (((char *) (-3 + tem_55X))))))));
+  arg1K0 = ((SstackS) + 4);
+  arg0K1 = 0;
+  goto L9949;}
+ L9949: {
+  p_56X = arg1K0;
+  i_57X = arg0K1;
+  if ((2 == (3 & (*((long *) p_56X))))) {
+    if ((22 == (*((long *) p_56X)))) {
+      arg0K0 = (-1 + i_57X);
+      goto L9890;}
+    else {
+      arg0K0 = i_57X;
+      goto L9890;}}
+  else {
+    arg1K0 = (p_56X + 4);
+    arg0K1 = (1 + i_57X);
+    goto L9949;}}
+ L9890: {
+  v_58X = arg0K0;
+  push_continuationB((Scode_pointerS), v_58X);
+  *((long *) (SstackS)) = (((opcode_54X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((exception_52X)<<2));
+  SstackS = ((SstackS) + -4);
+  return;}
+}
+static long make_registered_channel(long mode_59X, long id_60X, long os_index_61X, long key_62X, long *TT0)
+{
+  long x_66X;
+  char * addr_65X;
+  char x_64X;
+  char temp_63X;
+ {  temp_63X = os_index_61X < (Snumber_of_channelsS);
+  if (temp_63X) {
+    goto L10816;}
+  else {
+    x_64X = add_more_channels(os_index_61X);
+    if (x_64X) {
+      goto L10816;}
+    else {
+      *TT0 = 9;
+      return 1;}}}
+ L10816: {
+  if ((1 == (*((Svm_channelsS) + os_index_61X)))) {
+    addr_65X = ALLOCATE_SPACE(5, 24);
+    *((long *) addr_65X) = 5142;
+    x_66X = 3 + (((long) (addr_65X + 4)));
+    *((long *) (((char *) (-3 + x_66X)))) = (((mode_59X)<<2));
+    *((long *) ((((char *) (-3 + x_66X))) + 4)) = id_60X;
+    *((long *) ((((char *) (-3 + x_66X))) + 8)) = (((os_index_61X)<<2));
+    *((long *) ((((char *) (-3 + x_66X))) + 12)) = 1;
+    *((long *) ((((char *) (-3 + x_66X))) + 16)) = 1;
+    *((Svm_channelsS) + os_index_61X) = x_66X;
+    *TT0 = 9;
+    return x_66X;}
+  else {
+    *TT0 = 11;
+    return 1;}}
+}
+static long channel_close_error(long status_67X, long index_68X, long id_69X)
+{
+  long v_70X;
+ {  ps_write_string("Error: ", (stderr));
+  ps_write_string((ps_error_string(status_67X)), (stderr));
+  { long ignoreXX;
+  PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+  ps_write_string(" while closing port ", (stderr));
+  if ((3 == (3 & id_69X))) {
+    if ((16 == (31 & ((((*((long *) ((((char *) (-3 + id_69X))) + -4))))>>2))))) {
+      ps_write_string((((char *)(((char *) (-3 + id_69X))))), (stderr));
+      goto L11462;}
+    else {
+      goto L11456;}}
+  else {
+    goto L11456;}}
+ L11462: {
+  PS_WRITE_CHAR(10, (stderr), v_70X)
+  return v_70X;}
+ L11456: {
+  ps_write_integer((((index_68X)>>2)), (stderr));
+  goto L11462;}
+}
+static void HtopD8861(void)
+{
+  char * arg1K0;
+  long arg0K1;
+  long arg0K0;
+  long env_113X;
+  long env_112X;
+  long last_env_111X;
+  long cont_110X;
+  long env_109X;
+  long v_108X;
+  long env_107X;
+  long p_106X;
+  long arg_count_105X;
+  long i_104X;
+  char * p_103X;
+  char * addr_102X;
+  long val_101X;
+  long unused_100X;
+  char * a_99X;
+  char x_98X;
+  long pair_97X;
+  long v_96X;
+  long v_95X;
+  long env_94X;
+  long alist_93X;
+  long x2_92X;
+  char * cell_91X;
+  long i_90X;
+  long x2_89X;
+  char * cell_88X;
+  long v_87X;
+  long v_86X;
+  long v_85X;
+  long v_84X;
+  long v_83X;
+  long v_82X;
+  long v_81X;
+  long v_80X;
+  long v_79X;
+  long v_78X;
+  long v_77X;
+  long v_76X;
+  long v_75X;
+  long v_74X;
+  char * frame_73X;
+  long length_72X;
+  char * frame_71X;
+ {  arg1K0 = (Sexternal_root_stackS);
+  goto L6255;}
+ L6255: {
+  frame_71X = arg1K0;
+  if ((frame_71X == NULL)) {
+    arg1K0 = (Spermanent_external_rootsS);
+    goto L6281;}
+  else {
+    length_72X = *((long *) frame_71X);
+    arg0K0 = 0;
+    goto L6263;}}
+ L6281: {
+  frame_73X = arg1K0;
+  if ((frame_73X == NULL)) {
+    s48_initializing_gc_root();
+    v_74X = s48_trace_value((Simported_bindingsS));
+    Simported_bindingsS = v_74X;
+    v_75X = s48_trace_value((Sexported_bindingsS));
+    Sexported_bindingsS = v_75X;
+    Ssaved_pcS = (((((Scode_pointerS) - (((char *) (-3 + (*((long *) (((char *) (-3 + (StemplateS)))))))))))<<2));
+    v_76X = s48_trace_value((StemplateS));
+    StemplateS = v_76X;
+    v_77X = s48_trace_value((SvalS));
+    SvalS = v_77X;
+    v_78X = s48_trace_value((Scurrent_threadS));
+    Scurrent_threadS = v_78X;
+    v_79X = s48_trace_value((Ssession_dataS));
+    Ssession_dataS = v_79X;
+    v_80X = s48_trace_value((Sexception_handlersS));
+    Sexception_handlersS = v_80X;
+    v_81X = s48_trace_value((Sexception_templateS));
+    Sexception_templateS = v_81X;
+    v_82X = s48_trace_value((Sinterrupt_handlersS));
+    Sinterrupt_handlersS = v_82X;
+    v_83X = s48_trace_value((Sinterrupt_templateS));
+    Sinterrupt_templateS = v_83X;
+    v_84X = s48_trace_value((Sinterrupted_templateS));
+    Sinterrupted_templateS = v_84X;
+    v_85X = s48_trace_value((Sfinalize_theseS));
+    Sfinalize_theseS = v_85X;
+    v_86X = s48_trace_value((Sos_signal_typeS));
+    Sos_signal_typeS = v_86X;
+    v_87X = s48_trace_value((Sos_signal_argumentS));
+    Sos_signal_argumentS = v_87X;
+    arg0K0 = (Sfinalizer_alistS);
+    goto L5289;}
+  else {
+    cell_88X = ((char *) (*((long *) (frame_73X + 4))));
+    x2_89X = s48_trace_value((*((long *) cell_88X)));
+    *((long *) cell_88X) = x2_89X;
+    arg1K0 = (((char *) (*((long *) frame_73X))));
+    goto L6281;}}
+ L6263: {
+  i_90X = arg0K0;
+  if ((i_90X == length_72X)) {
+    arg1K0 = (((char *) (*((long *) (frame_71X + 4)))));
+    goto L6255;}
+  else {
+    cell_91X = ((char *) (*((long *) (frame_71X + (8 + (((i_90X)<<2)))))));
+    x2_92X = s48_trace_value((*((long *) cell_91X)));
+    *((long *) cell_91X) = x2_92X;
+    arg0K0 = (1 + i_90X);
+    goto L6263;}}
+ L5289: {
+  alist_93X = arg0K0;
+  if ((25 == alist_93X)) {
+    env_94X = s48_trace_value((SenvS));
+    SenvS = env_94X;
+    v_95X = s48_trace_value((Spending_channels_headS));
+    Spending_channels_headS = v_95X;
+    v_96X = s48_trace_value((Spending_channels_tailS));
+    Spending_channels_tailS = v_96X;
+    if ((Sstack_warningPS)) {
+      arg1K0 = (Sstack_beginS);
+      goto L5883;}
+    else {
+      goto L5916;}}
+  else {
+    pair_97X = *((long *) (((char *) (-3 + alist_93X))));
+    x_98X = s48_extantP((*((long *) (((char *) (-3 + pair_97X))))));
+    if (x_98X) {
+      goto L5314;}
+    else {
+      s48_trace_stob_contentsB((*((long *) (((char *) (-3 + pair_97X))))));
+      goto L5314;}}}
+ L5883: {
+  a_99X = arg1K0;
+  if ((252645135 == (*((long *) a_99X)))) {
+    arg1K0 = (a_99X + 4);
+    goto L5883;}
+  else {
+    unused_100X = (((a_99X - (Sstack_beginS)))>>2);
+    if ((unused_100X < 30)) {
+      { long ignoreXX;
+      PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+      ps_write_string("[Alert: stack overconsumption (", (stderr));
+      ps_write_integer(unused_100X, (stderr));
+      ps_write_string("); please inform the Scheme 48 implementors]", (stderr));
+      { long ignoreXX;
+      PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+      Sstack_warningPS = 0;
+      goto L5916;}
+    else {
+      goto L5916;}}}
+ L5916: {
+  arg1K0 = ((SstackS) + 4);
+  arg0K1 = 0;
+  goto L5981;}
+ L5314: {
+  val_101X = s48_trace_value((*((long *) ((((char *) (-3 + pair_97X))) + 4))));
+  addr_102X = (((char *) (-3 + pair_97X))) + 4;
+  S48_WRITE_BARRIER(pair_97X, addr_102X, val_101X);
+  *((long *) addr_102X) = val_101X;
+  arg0K0 = (*((long *) ((((char *) (-3 + alist_93X))) + 4)));
+  goto L5289;}
+ L5981: {
+  p_103X = arg1K0;
+  i_104X = arg0K1;
+  if ((2 == (3 & (*((long *) p_103X))))) {
+    if ((22 == (*((long *) p_103X)))) {
+      arg0K0 = (-1 + i_104X);
+      goto L5918;}
+    else {
+      arg0K0 = i_104X;
+      goto L5918;}}
+  else {
+    arg1K0 = (p_103X + 4);
+    arg0K1 = (1 + i_104X);
+    goto L5981;}}
+ L5918: {
+  arg_count_105X = arg0K0;
+  s48_trace_locationsB(((SstackS) + 4), ((SstackS) + (4 + (((arg_count_105X)<<2)))));
+  p_106X = SenvS;
+  if ((3 == (3 & p_106X))) {
+    if ((p_106X < (((long) (Sstack_beginS))))) {
+      goto L5934;}
+    else {
+      if (((((long) (Sstack_endS))) < p_106X)) {
+        goto L5934;}
+      else {
+        env_107X = SenvS;
+        arg0K0 = env_107X;
+        goto L6094;}}}
+  else {
+    goto L5934;}}
+ L5934: {
+  v_108X = s48_trace_value((SenvS));
+  SenvS = v_108X;
+  goto L5939;}
+ L6094: {
+  env_109X = arg0K0;
+  if ((3 == (3 & env_109X))) {
+    if ((env_109X < (((long) (Sstack_beginS))))) {
+      goto L5939;}
+    else {
+      if (((((long) (Sstack_endS))) < env_109X)) {
+        goto L5939;}
+      else {
+        s48_trace_stob_contentsB(env_109X);
+        arg0K0 = (*((long *) (((char *) (-3 + env_109X)))));
+        goto L6094;}}}
+  else {
+    goto L5939;}}
+ L5939: {
+  arg0K0 = (ScontS);
+  arg0K1 = 0;
+  goto L5944;}
+ L5944: {
+  cont_110X = arg0K0;
+  last_env_111X = arg0K1;
+  env_112X = *((long *) ((((char *) (-3 + cont_110X))) + 12));
+  s48_trace_stob_contentsB(cont_110X);
+  if ((env_112X == last_env_111X)) {
+    goto L5962;}
+  else {
+    arg0K0 = env_112X;
+    goto L6049;}}
+ L5962: {
+  if ((cont_110X == (Sbottom_of_stackS))) {
+    return;}
+  else {
+    arg0K0 = (*((long *) (((char *) (-3 + cont_110X)))));
+    arg0K1 = env_112X;
+    goto L5944;}}
+ L6049: {
+  env_113X = arg0K0;
+  if ((3 == (3 & env_113X))) {
+    if ((env_113X < (((long) (Sstack_beginS))))) {
+      goto L5962;}
+    else {
+      if (((((long) (Sstack_endS))) < env_113X)) {
+        goto L5962;}
+      else {
+        s48_trace_stob_contentsB(env_113X);
+        arg0K0 = (*((long *) (((char *) (-3 + env_113X)))));
+        goto L6049;}}}
+  else {
+    goto L5962;}}
+}
+static long Hlookup2102(long table_114X, long string_115X, long key_116X)
+{
+  long arg0K1;
+  long arg0K0;
+  long len_127X;
+  long s2_126X;
+  char * addr_125X;
+  long x_124X;
+  char * addr_123X;
+  long foo_122X;
+  long bucket_121X;
+  long index_120X;
+  long h_119X;
+  long i_118X;
+  long n_117X;
+ {  n_117X = -1 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + string_115X))) + -4))))>>8));
+  arg0K0 = 0;
+  arg0K1 = 0;
+  goto L13083;}
+ L13083: {
+  i_118X = arg0K0;
+  h_119X = arg0K1;
+  if ((i_118X < n_117X)) {
+    arg0K0 = (1 + i_118X);
+    arg0K1 = (h_119X + (((*((unsigned char *) ((((char *) (-3 + string_115X))) + i_118X))))));
+    goto L13083;}
+  else {
+    index_120X = 1023 & h_119X;
+    bucket_121X = *((long *) ((((char *) (-3 + table_114X))) + (((index_120X)<<2))));
+    arg0K0 = bucket_121X;
+    goto L13051;}}
+ L13051: {
+  foo_122X = arg0K0;
+  if ((1 == foo_122X)) {
+    addr_123X = ALLOCATE_SPACE(13, 20);
+    *((long *) addr_123X) = 4150;
+    x_124X = 3 + (((long) (addr_123X + 4)));
+    *((long *) (((char *) (-3 + x_124X)))) = string_115X;
+    *((long *) ((((char *) (-3 + x_124X))) + 4)) = 1;
+    *((long *) ((((char *) (-3 + x_124X))) + 8)) = 13;
+    *((long *) ((((char *) (-3 + x_124X))) + 12)) = bucket_121X;
+    addr_125X = (((char *) (-3 + table_114X))) + (((index_120X)<<2));
+    S48_WRITE_BARRIER(table_114X, addr_125X, x_124X);
+    *((long *) addr_125X) = x_124X;
+    return x_124X;}
+  else {
+    s2_126X = *((long *) (((char *) (-3 + foo_122X))));
+    len_127X = (long)(((unsigned long)(*((long *) ((((char *) (-3 + string_115X))) + -4))))>>8);
+    if ((len_127X == ((long)(((unsigned long)(*((long *) ((((char *) (-3 + s2_126X))) + -4))))>>8)))) {
+      if (((!memcmp((void *)(((char *) (-3 + s2_126X))), (void *)(((char *) (-3 + string_115X))),len_127X)))) {
+        return foo_122X;}
+      else {
+        goto L13067;}}
+    else {
+      goto L13067;}}}
+ L13067: {
+  arg0K0 = (*((long *) ((((char *) (-3 + foo_122X))) + 12)));
+  goto L13051;}
+}
+static long Hlookup2083(long table_128X, long string_129X, long key_130X)
+{
+  long arg0K1;
+  long arg0K0;
+  long len_141X;
+  long s2_140X;
+  char * addr_139X;
+  long x_138X;
+  char * addr_137X;
+  long foo_136X;
+  long bucket_135X;
+  long index_134X;
+  long h_133X;
+  long i_132X;
+  long n_131X;
+ {  n_131X = -1 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + string_129X))) + -4))))>>8));
+  arg0K0 = 0;
+  arg0K1 = 0;
+  goto L13208;}
+ L13208: {
+  i_132X = arg0K0;
+  h_133X = arg0K1;
+  if ((i_132X < n_131X)) {
+    arg0K0 = (1 + i_132X);
+    arg0K1 = (h_133X + (((*((unsigned char *) ((((char *) (-3 + string_129X))) + i_132X))))));
+    goto L13208;}
+  else {
+    index_134X = 1023 & h_133X;
+    bucket_135X = *((long *) ((((char *) (-3 + table_128X))) + (((index_134X)<<2))));
+    arg0K0 = bucket_135X;
+    goto L13176;}}
+ L13176: {
+  foo_136X = arg0K0;
+  if ((1 == foo_136X)) {
+    addr_137X = ALLOCATE_SPACE(13, 20);
+    *((long *) addr_137X) = 4150;
+    x_138X = 3 + (((long) (addr_137X + 4)));
+    *((long *) (((char *) (-3 + x_138X)))) = string_129X;
+    *((long *) ((((char *) (-3 + x_138X))) + 4)) = 5;
+    *((long *) ((((char *) (-3 + x_138X))) + 8)) = 13;
+    *((long *) ((((char *) (-3 + x_138X))) + 12)) = bucket_135X;
+    addr_139X = (((char *) (-3 + table_128X))) + (((index_134X)<<2));
+    S48_WRITE_BARRIER(table_128X, addr_139X, x_138X);
+    *((long *) addr_139X) = x_138X;
+    return x_138X;}
+  else {
+    s2_140X = *((long *) (((char *) (-3 + foo_136X))));
+    len_141X = (long)(((unsigned long)(*((long *) ((((char *) (-3 + string_129X))) + -4))))>>8);
+    if ((len_141X == ((long)(((unsigned long)(*((long *) ((((char *) (-3 + s2_140X))) + -4))))>>8)))) {
+      if (((!memcmp((void *)(((char *) (-3 + s2_140X))), (void *)(((char *) (-3 + string_129X))),len_141X)))) {
+        return foo_136X;}
+      else {
+        goto L13192;}}
+    else {
+      goto L13192;}}}
+ L13192: {
+  arg0K0 = (*((long *) ((((char *) (-3 + foo_136X))) + 12)));
+  goto L13176;}
+}
+static void HtopD8854(void)
+{
+  long arg0K2;
+  long arg0K1;
+  long arg0K0;
+  long status_168X;
+  long id_167X;
+  long new_166X;
+  long id_165X;
+  long header_164X;
+  long channel_163X;
+  long i_162X;
+  char * addr_161X;
+  long l_160X;
+  long v_159X;
+  char * addr_158X;
+  char * addr_157X;
+  char * addr_156X;
+  char * addr_155X;
+  long val_154X;
+  char tracedP_153X;
+  long next_152X;
+  long thing_151X;
+  long pair_150X;
+  long alist_149X;
+  long l2_148X;
+  long goners_147X;
+  long okay_146X;
+  long alist_145X;
+  long pc_144X;
+  long tem_143X;
+  long new_142X;
+ {  new_142X = s48_trace_value((Sthe_symbol_tableS));
+  HcleanerB2160(new_142X);
+  Sthe_symbol_tableS = new_142X;
+  tem_143X = StemplateS;
+  pc_144X = Ssaved_pcS;
+  StemplateS = tem_143X;
+  Scode_pointerS = ((((char *) (-3 + (*((long *) (((char *) (-3 + tem_143X)))))))) + (((pc_144X)>>2)));
+  arg0K0 = (Sfinalizer_alistS);
+  arg0K1 = 25;
+  arg0K2 = 25;
+  goto L7722;}
+ L7722: {
+  alist_145X = arg0K0;
+  okay_146X = arg0K1;
+  goners_147X = arg0K2;
+  if ((25 == alist_145X)) {
+    Sfinalizer_alistS = okay_146X;
+    l2_148X = Sfinalize_theseS;
+    if ((25 == goners_147X)) {
+      arg0K0 = l2_148X;
+      goto L7730;}
+    else {
+      arg0K0 = goners_147X;
+      goto L7783;}}
+  else {
+    alist_149X = s48_trace_value(alist_145X);
+    pair_150X = s48_trace_value((*((long *) (((char *) (-3 + alist_149X))))));
+    thing_151X = *((long *) (((char *) (-3 + pair_150X))));
+    next_152X = *((long *) ((((char *) (-3 + alist_149X))) + 4));
+    tracedP_153X = s48_extantP(thing_151X);
+    val_154X = s48_trace_value(thing_151X);
+    addr_155X = ((char *) (-3 + pair_150X));
+    S48_WRITE_BARRIER(pair_150X, addr_155X, val_154X);
+    *((long *) addr_155X) = val_154X;
+    addr_156X = ((char *) (-3 + alist_149X));
+    S48_WRITE_BARRIER(alist_149X, addr_156X, pair_150X);
+    *((long *) addr_156X) = pair_150X;
+    if (tracedP_153X) {
+      addr_157X = (((char *) (-3 + alist_149X))) + 4;
+      S48_WRITE_BARRIER(alist_149X, addr_157X, okay_146X);
+      *((long *) addr_157X) = okay_146X;
+      arg0K0 = next_152X;
+      arg0K1 = alist_149X;
+      arg0K2 = goners_147X;
+      goto L7722;}
+    else {
+      addr_158X = (((char *) (-3 + alist_149X))) + 4;
+      S48_WRITE_BARRIER(alist_149X, addr_158X, goners_147X);
+      *((long *) addr_158X) = goners_147X;
+      arg0K0 = next_152X;
+      arg0K1 = okay_146X;
+      arg0K2 = alist_149X;
+      goto L7722;}}}
+ L7730: {
+  v_159X = arg0K0;
+  Sfinalize_theseS = v_159X;
+  arg0K0 = 0;
+  goto L12515;}
+ L7783: {
+  l_160X = arg0K0;
+  if ((25 == (*((long *) ((((char *) (-3 + l_160X))) + 4))))) {
+    addr_161X = (((char *) (-3 + l_160X))) + 4;
+    S48_WRITE_BARRIER(l_160X, addr_161X, l2_148X);
+    *((long *) addr_161X) = l2_148X;
+    arg0K0 = goners_147X;
+    goto L7730;}
+  else {
+    arg0K0 = (*((long *) ((((char *) (-3 + l_160X))) + 4)));
+    goto L7783;}}
+ L12515: {
+  i_162X = arg0K0;
+  if ((i_162X == (Snumber_of_channelsS))) {
+    Spending_interruptsS = (4 | (Spending_interruptsS));
+    if ((0 == ((Spending_interruptsS) & (Senabled_interruptsS)))) {
+      s48_Spending_interruptPS = 0;
+      if ((s48_Spending_eventsPS)) {
+        s48_Spending_interruptPS = 1;
+        return;}
+      else {
+        return;}}
+    else {
+      s48_Spending_interruptPS = 1;
+      return;}}
+  else {
+    channel_163X = *((Svm_channelsS) + i_162X);
+    if ((1 == channel_163X)) {
+      goto L12551;}
+    else {
+      header_164X = *((long *) ((((char *) (-3 + channel_163X))) + -4));
+      if ((3 == (3 & header_164X))) {
+        arg0K0 = header_164X;
+        goto L12544;}
+      else {
+        if ((0 == (*((long *) (((char *) (-3 + channel_163X))))))) {
+          arg0K0 = 1;
+          goto L12544;}
+        else {
+          id_165X = *((long *) ((((char *) (-3 + channel_163X))) + 4));
+          if ((0 == (3 & id_165X))) {
+            arg0K0 = id_165X;
+            goto L12227;}
+          else {
+            if ((3 == (3 & (*((long *) ((((char *) (-3 + id_165X))) + -4)))))) {
+              arg0K0 = (*((long *) ((((char *) (-3 + id_165X))) + -4)));
+              goto L12227;}
+            else {
+              arg0K0 = id_165X;
+              goto L12227;}}}}}}}
+ L12551: {
+  arg0K0 = (1 + i_162X);
+  goto L12515;}
+ L12544: {
+  new_166X = arg0K0;
+  *((Svm_channelsS) + i_162X) = new_166X;
+  goto L12551;}
+ L12227: {
+  id_167X = arg0K0;
+  status_168X = close_channelB(channel_163X);
+  if ((status_168X == NO_ERRORS)) {
+    goto L12242;}
+  else {
+    channel_close_error(status_168X, (*((long *) ((((char *) (-3 + channel_163X))) + 8))), id_167X);
+    goto L12242;}}
+ L12242: {
+  ps_write_string("Channel closed: ", (stderr));
+  if ((0 == (3 & id_167X))) {
+    ps_write_integer((((id_167X)>>2)), (stderr));
+    goto L12260;}
+  else {
+    ps_write_string((((char *)(((char *) (-3 + id_167X))))), (stderr));
+    goto L12260;}}
+ L12260: {
+  ps_write_string(" ", (stderr));
+  ps_write_integer(((((*((long *) ((((char *) (-3 + channel_163X))) + 8))))>>2)), (stderr));
+  { long ignoreXX;
+  PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+  arg0K0 = 1;
+  goto L12544;}
+}
+static long collect_saving_temps(long value0_169X, long value1_170X, long *TT0)
+{
+  long value0_172X;
+  long value1_171X;
+ {  s48_begin_collection();
+  (*(Sgc_root_procS))();
+  value1_171X = s48_trace_value(value1_170X);
+  value0_172X = s48_trace_value(value0_169X);
+  s48_do_gc();
+  (*(Spost_gc_cleanupS))();
+  s48_end_collection();
+  *TT0 = value1_171X;
+  return value0_172X;}
+}
+void s48_set_extension_valueB(long value_173X)
+{
+
+ {  s48_Sextension_valueS = value_173X;
+  return;}
+}
+void s48_note_event(void)
+{
+
+ {  s48_Spending_eventsPS = 1;
+  s48_Spending_interruptPS = 1;
+  return;}
+}
+void s48_set_os_signal(long type_174X, long argument_175X)
+{
+
+ {  Sos_signal_typeS = type_174X;
+  Sos_signal_argumentS = argument_175X;
+  return;}
+}
+long s48_exported_bindings(void)
+{
+
+ {  return (Sexported_bindingsS);}
+}
+char * s48_set_gc_roots_baseB(void)
+{
+  char * old_base_176X;
+ {  old_base_176X = Sexternal_root_stack_baseS;
+  Sexternal_root_stack_baseS = (Sexternal_root_stackS);
+  return old_base_176X;}
+}
+char s48_release_gc_roots_baseB(char * old_base_177X)
+{
+  char okayP_178X;
+ {  okayP_178X = (Sexternal_root_stackS) == (Sexternal_root_stack_baseS);
+  Sexternal_root_stack_baseS = old_base_177X;
+  return okayP_178X;}
+}
+void s48_disable_interruptsB(void)
+{
+
+ {  s48_Spending_interruptPS = 0;
+  Senabled_interruptsS = 0;
+  return;}
+}
+void s48_push_gc_rootsB(char * frame_179X, long n_180X)
+{
+
+ {  *((long *) frame_179X) = n_180X;
+  *((long *) (frame_179X + 4)) = (((long) (Sexternal_root_stackS)));
+  Sexternal_root_stackS = frame_179X;
+  return;}
+}
+void s48_register_gc_rootB(char * loc_addr_181X)
+{
+  char * frame_182X;
+ {  frame_182X = (char *)malloc(8);
+  if ((frame_182X == NULL)) {
+    ps_error("out of memory registering a global root", 0);
+    goto L3175;}
+  else {
+    goto L3175;}}
+ L3175: {
+  *((long *) frame_182X) = (((long) (Spermanent_external_rootsS)));
+  *((long *) (frame_182X + 4)) = (((long) loc_addr_181X));
+  Spermanent_external_rootsS = frame_182X;
+  return;}
+}
+void s48_stack_setB(long x_183X, long value_184X)
+{
+
+ {  *((long *) ((SstackS) + (4 + (((x_183X)<<2))))) = value_184X;
+  return;}
+}
+long s48_stack_ref(long i_185X)
+{
+
+ {  return (*((long *) ((SstackS) + (4 + (((i_185X)<<2))))));}
+}
+void s48_push(long x_186X)
+{
+
+ {  *((long *) (SstackS)) = x_186X;
+  SstackS = ((SstackS) + -4);
+  return;}
+}
+long s48_resetup_external_exception(long new_why_187X, long additional_nargs_188X)
+{
+  long old_why_190X;
+  long old_nargs_189X;
+ {  old_nargs_189X = Sexternal_exception_nargsS;
+  old_why_190X = *((long *) ((SstackS) + (4 + (((old_nargs_189X)<<2)))));
+  *((long *) ((SstackS) + (4 + (((old_nargs_189X)<<2))))) = (((new_why_187X)<<2));
+  Sexternal_exception_nargsS = (old_nargs_189X + additional_nargs_188X);
+  return old_why_190X;}
+}
+void s48_enable_interruptsB(void)
+{
+
+ {  Senabled_interruptsS = -1;
+  if ((0 == ((Spending_interruptsS) & (Senabled_interruptsS)))) {
+    s48_Spending_interruptPS = 0;
+    if ((s48_Spending_eventsPS)) {
+      s48_Spending_interruptPS = 1;
+      return;}
+    else {
+      return;}}
+  else {
+    s48_Spending_interruptPS = 1;
+    return;}}
+}
+char s48_pop_gc_rootsB(void)
+{
+
+ {  if (((Sexternal_root_stackS) == (Sexternal_root_stack_baseS))) {
+    return 0;}
+  else {
+    Sexternal_root_stackS = (((char *) (*((long *) ((Sexternal_root_stackS) + 4)))));
+    return 1;}}
+}
+void s48_mark_traced_channels_closedB(void)
+{
+  long arg0K0;
+  char * addr_196X;
+  char * addr_195X;
+  long descriptor_194X;
+  long header_193X;
+  long channel_192X;
+  long i_191X;
+ {  arg0K0 = 0;
+  goto L6332;}
+ L6332: {
+  i_191X = arg0K0;
+  if ((i_191X == (Snumber_of_channelsS))) {
+    return;}
+  else {
+    channel_192X = *((Svm_channelsS) + i_191X);
+    if ((1 == channel_192X)) {
+      goto L6392;}
+    else {
+      header_193X = *((long *) ((((char *) (-3 + channel_192X))) + -4));
+      if ((3 == (3 & header_193X))) {
+        ps_write_string("Channel closed in dumped image: ", (stderr));
+        descriptor_194X = *((long *) ((((char *) (-3 + channel_192X))) + 4));
+        if ((0 == (3 & descriptor_194X))) {
+          ps_write_integer(((((*((long *) ((((char *) (-3 + channel_192X))) + 4))))>>2)), (stderr));
+          goto L6378;}
+        else {
+          ps_write_string((((char *)(((char *) (-3 + (*((long *) ((((char *) (-3 + channel_192X))) + 4)))))))), (stderr));
+          goto L6378;}}
+      else {
+        goto L6392;}}}}
+ L6392: {
+  arg0K0 = (1 + i_191X);
+  goto L6332;}
+ L6378: {
+  { long ignoreXX;
+  PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+  addr_195X = ((char *) (-3 + header_193X));
+  S48_WRITE_BARRIER(header_193X, addr_195X, 0);
+  *((long *) addr_195X) = 0;
+  addr_196X = (((char *) (-3 + header_193X))) + 8;
+  S48_WRITE_BARRIER(header_193X, addr_196X, -4);
+  *((long *) addr_196X) = -4;
+  goto L6392;}
+}
+long s48_set_channel_os_index(long channel_197X, long os_index_198X)
+{
+  char * addr_205X;
+  long val_204X;
+  long v_203X;
+  long x_202X;
+  long old_index_201X;
+  char x_200X;
+  char temp_199X;
+ {  temp_199X = os_index_198X < (Snumber_of_channelsS);
+  if (temp_199X) {
+    goto L7901;}
+  else {
+    x_200X = add_more_channels(os_index_198X);
+    if (x_200X) {
+      goto L7901;}
+    else {
+      return 36;}}}
+ L7901: {
+  if ((1 == (*((Svm_channelsS) + os_index_198X)))) {
+    old_index_201X = (((*((long *) ((((char *) (-3 + channel_197X))) + 8))))>>2);
+    x_202X = *((long *) ((((char *) (-3 + channel_197X))) + 16));
+    if ((5 == x_202X)) {
+      v_203X = ps_abort_fd_op(old_index_201X);
+      enqueue_channelB(old_index_201X, v_203X);
+      goto L7887;}
+    else {
+      goto L7887;}}
+  else {
+    return 44;}}
+ L7887: {
+  *((Svm_channelsS) + old_index_201X) = 1;
+  *((Svm_channelsS) + os_index_198X) = channel_197X;
+  val_204X = ((os_index_198X)<<2);
+  addr_205X = (((char *) (-3 + channel_197X))) + 8;
+  S48_WRITE_BARRIER(channel_197X, addr_205X, val_204X);
+  *((long *) addr_205X) = val_204X;
+  return 5;}
+}
+long s48_cleaned_imported_bindings(void)
+{
+  long arg0K1;
+  long arg0K0;
+  long v_219X;
+  char * addr_218X;
+  long entry_217X;
+  char * addr_216X;
+  long new_foo_215X;
+  char v_214X;
+  char * addr_213X;
+  long okay_212X;
+  long foo_211X;
+  long i_210X;
+  long foo_209X;
+  long i_208X;
+  long table_207X;
+  long table_206X;
+ {  table_206X = s48_trace_value((Simported_bindingsS));
+  table_207X = s48_trace_value(table_206X);
+  arg0K0 = 0;
+  goto L8578;}
+ L8578: {
+  i_208X = arg0K0;
+  if ((1024 == i_208X)) {
+    arg0K0 = 0;
+    goto L9667;}
+  else {
+    foo_209X = *((long *) ((((char *) (-3 + table_207X))) + (((i_208X)<<2))));
+    arg0K0 = foo_209X;
+    arg0K1 = 1;
+    goto L8598;}}
+ L9667: {
+  i_210X = arg0K0;
+  if ((1024 == i_210X)) {
+    return table_206X;}
+  else {
+    arg0K0 = (*((long *) ((((char *) (-3 + table_206X))) + (((i_210X)<<2)))));
+    goto L9675;}}
+ L8598: {
+  foo_211X = arg0K0;
+  okay_212X = arg0K1;
+  if ((1 == foo_211X)) {
+    addr_213X = (((char *) (-3 + table_207X))) + (((i_208X)<<2));
+    S48_WRITE_BARRIER(table_207X, addr_213X, okay_212X);
+    *((long *) addr_213X) = okay_212X;
+    arg0K0 = (1 + i_208X);
+    goto L8578;}
+  else {
+    v_214X = s48_extantP(foo_211X);
+    if (v_214X) {
+      new_foo_215X = s48_trace_value(foo_211X);
+      addr_216X = (((char *) (-3 + new_foo_215X))) + 12;
+      S48_WRITE_BARRIER(new_foo_215X, addr_216X, okay_212X);
+      *((long *) addr_216X) = okay_212X;
+      arg0K0 = new_foo_215X;
+      goto L8603;}
+    else {
+      arg0K0 = okay_212X;
+      goto L8603;}}}
+ L9675: {
+  entry_217X = arg0K0;
+  if ((1 == entry_217X)) {
+    arg0K0 = (1 + i_210X);
+    goto L9667;}
+  else {
+    addr_218X = (((char *) (-3 + entry_217X))) + 8;
+    S48_WRITE_BARRIER(entry_217X, addr_218X, 529);
+    *((long *) addr_218X) = 529;
+    arg0K0 = (*((long *) ((((char *) (-3 + entry_217X))) + 12)));
+    goto L9675;}}
+ L8603: {
+  v_219X = arg0K0;
+  arg0K0 = (*((long *) ((((char *) (-3 + foo_211X))) + 12)));
+  arg0K1 = v_219X;
+  goto L8598;}
+}
+long s48_copy_symbol_table(void)
+{
+  long new_220X;
+ {  new_220X = s48_trace_value((Sthe_symbol_tableS));
+  HcleanerB2160(new_220X);
+  return new_220X;}
+}
+void s48_setup_external_exception(long why_221X, long nargs_222X)
+{
+
+ {  push_exception_continuationB(why_221X, 1);
+  if ((10 < nargs_222X)) {
+    ps_error("too many arguments from external exception", 0);
+    goto L11018;}
+  else {
+    goto L11018;}}
+ L11018: {
+  Sexternal_exception_nargsS = nargs_222X;
+  Sexternal_exceptionPS = 1;
+  return;}
+}
+void s48_close_channel(long os_index_223X)
+{
+  long obj_224X;
+ {  if ((os_index_223X < 0)) {
+    return;}
+  else {
+    if ((os_index_223X < (Snumber_of_channelsS))) {
+      obj_224X = *((Svm_channelsS) + os_index_223X);
+      if ((3 == (3 & obj_224X))) {
+        if ((5 == (31 & ((((*((long *) ((((char *) (-3 + obj_224X))) + -4))))>>2))))) {
+          close_channelB((*((Svm_channelsS) + os_index_223X)));
+          return;}
+        else {
+          return;}}
+      else {
+        return;}}
+    else {
+      return;}}}
+}
+char s48_warn_about_undefined_imported_bindings(void)
+{
+  long arg0K0;
+  long name_230X;
+  long entry_229X;
+  char temp_228X;
+  long i_227X;
+  long table_226X;
+  FILE * out_225X;
+ {  out_225X = stderr;
+  table_226X = Simported_bindingsS;
+  arg0K0 = 0;
+  goto L11558;}
+ L11558: {
+  i_227X = arg0K0;
+  temp_228X = 1024 == i_227X;
+  if (temp_228X) {
+    return temp_228X;}
+  else {
+    arg0K0 = (*((long *) ((((char *) (-3 + table_226X))) + (((i_227X)<<2)))));
+    goto L11566;}}
+ L11566: {
+  entry_229X = arg0K0;
+  if ((1 == entry_229X)) {
+    arg0K0 = (1 + i_227X);
+    goto L11558;}
+  else {
+    if ((17 == (255 & (*((long *) ((((char *) (-3 + entry_229X))) + 8)))))) {
+      name_230X = *((long *) (((char *) (-3 + entry_229X))));
+      ps_write_string("undefined imported name ", out_225X);
+      if ((3 == (3 & name_230X))) {
+        if ((16 == (31 & ((((*((long *) ((((char *) (-3 + name_230X))) + -4))))>>2))))) {
+          ps_write_string((((char *)(((char *) (-3 + name_230X))))), out_225X);
+          goto L11546;}
+        else {
+          goto L11544;}}
+      else {
+        goto L11544;}}
+    else {
+      goto L11569;}}}
+ L11546: {
+  { long ignoreXX;
+  PS_WRITE_CHAR(10, out_225X, ignoreXX) }
+  goto L11569;}
+ L11544: {
+  ps_write_string("<invalid name>", out_225X);
+  goto L11546;}
+ L11569: {
+  arg0K0 = (*((long *) ((((char *) (-3 + entry_229X))) + 12)));
+  goto L11566;}
+}
+void s48_define_exported_binding(char *name_231X, long value_232X)
+{
+  char arg2K0;
+  long arg0K2;
+  long arg0K1;
+  long arg0K0;
+  char * addr_245X;
+  long x_244X;
+  long name_243X;
+  long value_242X;
+  long key_241X;
+  long temp_240X;
+  long key_239X;
+  char okayP_238X;
+  char v_237X;
+  long temp1_236X;
+  long temp0_235X;
+  char v_234X;
+  long space_233X;
+ {  space_233X = 6 + ((((4 + (strlen((char *) name_231X))))>>2));
+  v_234X = AVAILABLEp(space_233X);
+  if (v_234X) {
+    arg2K0 = 1;
+    arg0K1 = 0;
+    arg0K2 = value_232X;
+    goto L14338;}
+  else {
+    temp0_235X = collect_saving_temps(value_232X, 1, &temp1_236X);
+    v_237X = AVAILABLEp(space_233X);
+    if (v_237X) {
+      arg2K0 = 1;
+      arg0K1 = 0;
+      arg0K2 = temp0_235X;
+      goto L14338;}
+    else {
+      arg2K0 = 0;
+      arg0K1 = 0;
+      arg0K2 = temp0_235X;
+      goto L14338;}}}
+ L14338: {
+  okayP_238X = arg2K0;
+  key_239X = arg0K1;
+  temp_240X = arg0K2;
+  if (okayP_238X) {
+    arg0K0 = key_239X;
+    arg0K1 = temp_240X;
+    goto L14319;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = key_239X;
+    arg0K1 = temp_240X;
+    goto L14319;}}
+ L14319: {
+  key_241X = arg0K0;
+  value_242X = arg0K1;
+  name_243X = enter_string(name_231X, key_241X);
+  x_244X = Hlookup2083((Simported_bindingsS), name_243X, key_241X);
+  addr_245X = (((char *) (-3 + x_244X))) + 8;
+  S48_WRITE_BARRIER(x_244X, addr_245X, value_242X);
+  *((long *) addr_245X) = value_242X;
+  return;}
+}
+long s48_add_channel(long mode_246X, long id_247X, long os_index_248X)
+{
+  char arg2K0;
+  long arg0K1;
+  long arg0K0;
+  long status_256X;
+  long channel_255X;
+  long v_254X;
+  long key_253X;
+  char okayP_252X;
+  char v_251X;
+  long temp1_250X;
+  char v_249X;
+ {  v_249X = AVAILABLEp(6);
+  if (v_249X) {
+    arg2K0 = 1;
+    arg0K1 = 0;
+    goto L14727;}
+  else {
+    collect_saving_temps(1, 1, &temp1_250X);
+    v_251X = AVAILABLEp(6);
+    if (v_251X) {
+      arg2K0 = 1;
+      arg0K1 = 0;
+      goto L14727;}
+    else {
+      arg2K0 = 0;
+      arg0K1 = 0;
+      goto L14727;}}}
+ L14727: {
+  okayP_252X = arg2K0;
+  key_253X = arg0K1;
+  if (okayP_252X) {
+    arg0K0 = key_253X;
+    goto L14710;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = key_253X;
+    goto L14710;}}
+ L14710: {
+  v_254X = arg0K0;
+  channel_255X = make_registered_channel((((mode_246X)>>2)), id_247X, os_index_248X, v_254X, &status_256X);
+  if ((3 == (3 & channel_255X))) {
+    if ((5 == (31 & ((((*((long *) ((((char *) (-3 + channel_255X))) + -4))))>>2))))) {
+      return channel_255X;}
+    else {
+      goto L14721;}}
+  else {
+    goto L14721;}}
+ L14721: {
+  return (((status_256X)<<2));}
+}
+long s48_get_imported_binding(char *name_257X)
+{
+  char arg2K0;
+  long arg0K1;
+  long arg0K0;
+  long name_265X;
+  long key_264X;
+  long key_263X;
+  char okayP_262X;
+  char v_261X;
+  long temp1_260X;
+  char v_259X;
+  long space_258X;
+ {  space_258X = 6 + ((((4 + (strlen((char *) name_257X))))>>2));
+  v_259X = AVAILABLEp(space_258X);
+  if (v_259X) {
+    arg2K0 = 1;
+    arg0K1 = 0;
+    goto L15416;}
+  else {
+    collect_saving_temps(1, 1, &temp1_260X);
+    v_261X = AVAILABLEp(space_258X);
+    if (v_261X) {
+      arg2K0 = 1;
+      arg0K1 = 0;
+      goto L15416;}
+    else {
+      arg2K0 = 0;
+      arg0K1 = 0;
+      goto L15416;}}}
+ L15416: {
+  okayP_262X = arg2K0;
+  key_263X = arg0K1;
+  if (okayP_262X) {
+    arg0K0 = key_263X;
+    goto L15403;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = key_263X;
+    goto L15403;}}
+ L15403: {
+  key_264X = arg0K0;
+  name_265X = enter_string(name_257X, key_264X);
+  return Hlookup2102((Sexported_bindingsS), name_265X, key_264X);}
+}
+long s48_allocate_stob(long type_266X, long size_267X)
+{
+  char * addr_271X;
+  char v_270X;
+  long temp1_269X;
+  char v_268X;
+ {  v_268X = AVAILABLEp(size_267X);
+  if (v_268X) {
+    goto L15711;}
+  else {
+    collect_saving_temps(1, 1, &temp1_269X);
+    v_270X = AVAILABLEp(size_267X);
+    if (v_270X) {
+      goto L15711;}
+    else {
+      ps_error("Scheme48 heap overflow", 0);
+      goto L15711;}}}
+ L15711: {
+  addr_271X = ALLOCATE_SPACE(type_266X, (4 + size_267X));
+  *((long *) addr_271X) = (2 + (((((((size_267X)<<6)) + type_266X))<<2)));
+  return (3 + (((long) (addr_271X + 4))));}
+}
+void s48_initialize_vm(char * stack_begin_272X, long stack_size_273X)
+{
+  char arg2K0;
+  char * arg1K0;
+  long arg0K2;
+  long arg0K1;
+  long arg0K0;
+  char * addr_344X;
+  long code_343X;
+  long temp_342X;
+  char * addr_341X;
+  char * addr_340X;
+  char * addr_339X;
+  long code_338X;
+  long temp_337X;
+  char * addr_336X;
+  char * addr_335X;
+  char v_334X;
+  long temp1_333X;
+  char v_332X;
+  long cont_331X;
+  char * addr_330X;
+  long code_329X;
+  long temp_328X;
+  char * addr_327X;
+  char * addr_326X;
+  char v_325X;
+  long temp1_324X;
+  char v_323X;
+  char * a_322X;
+  long size_321X;
+  char * start_320X;
+  char * stack_319X;
+  long v_318X;
+  char * addr_317X;
+  long i_316X;
+  char * addr_315X;
+  char * addr_314X;
+  long val_313X;
+  long index_312X;
+  long h_311X;
+  long i_310X;
+  long table_309X;
+  char * addr_308X;
+  long v_307X;
+  char * addr_306X;
+  long i_305X;
+  long n_304X;
+  long string_303X;
+  long foo_302X;
+  long table_301X;
+  long i_300X;
+  long table_299X;
+  char * addr_298X;
+  long exported_bindings_297X;
+  long imported_bindings_296X;
+  long n_295X;
+  long symbols_294X;
+  long temp1_293X;
+  long temp0_292X;
+  char okayP_291X;
+  char * addr_290X;
+  long maybe_289X;
+  long v_288X;
+  long maybe_287X;
+  long i_286X;
+  char v_285X;
+  long temp1_284X;
+  long temp0_283X;
+  char v_282X;
+  long imported_bindings_281X;
+  long exported_bindings_280X;
+  long table_279X;
+  char * addr_278X;
+  char v_277X;
+  long temp1_276X;
+  char v_275X;
+  long symbol_table_274X;
+ {  symbol_table_274X = s48_initial_symbols();
+  if ((symbol_table_274X == 1)) {
+    v_275X = AVAILABLEp(1025);
+    if (v_275X) {
+      goto L15442;}
+    else {
+      collect_saving_temps(1, 1, &temp1_276X);
+      v_277X = AVAILABLEp(1025);
+      if (v_277X) {
+        goto L15442;}
+      else {
+        ps_error("Scheme48 heap overflow", 0);
+        goto L15442;}}}
+  else {
+    Sthe_symbol_tableS = symbol_table_274X;
+    goto L15834;}}
+ L15442: {
+  addr_278X = ALLOCATE_SPACE(2, 4100);
+  *((long *) addr_278X) = 1048586;
+  table_279X = 3 + (((long) (addr_278X + 4)));
+  arg0K0 = 0;
+  goto L15517;}
+ L15834: {
+  exported_bindings_280X = s48_initial_exported_bindings();
+  imported_bindings_281X = s48_initial_imported_bindings();
+  v_282X = AVAILABLEp(2050);
+  if (v_282X) {
+    arg2K0 = 1;
+    arg0K1 = imported_bindings_281X;
+    arg0K2 = exported_bindings_280X;
+    goto L14420;}
+  else {
+    temp0_283X = collect_saving_temps(imported_bindings_281X, exported_bindings_280X, &temp1_284X);
+    v_285X = AVAILABLEp(2050);
+    if (v_285X) {
+      arg2K0 = 1;
+      arg0K1 = temp0_283X;
+      arg0K2 = temp1_284X;
+      goto L14420;}
+    else {
+      arg2K0 = 0;
+      arg0K1 = temp0_283X;
+      arg0K2 = temp1_284X;
+      goto L14420;}}}
+ L15517: {
+  i_286X = arg0K0;
+  if ((1024 == i_286X)) {
+    Sthe_symbol_tableS = table_279X;
+    maybe_287X = s48_find_all(1);
+    if ((maybe_287X == 1)) {
+      collect_saving_temps(0, 0, &v_288X);
+      maybe_289X = s48_find_all(1);
+      if ((maybe_289X == 1)) {
+        ps_error("insufficient heap space to build symbol table", 0);
+        arg0K0 = maybe_289X;
+        goto L15471;}
+      else {
+        arg0K0 = maybe_289X;
+        goto L15471;}}
+    else {
+      arg0K0 = maybe_287X;
+      goto L15471;}}
+  else {
+    addr_290X = (((char *) (-3 + table_279X))) + (((i_286X)<<2));
+    S48_WRITE_BARRIER(table_279X, addr_290X, 1);
+    *((long *) addr_290X) = 1;
+    arg0K0 = (1 + i_286X);
+    goto L15517;}}
+ L14420: {
+  okayP_291X = arg2K0;
+  temp0_292X = arg0K1;
+  temp1_293X = arg0K2;
+  if (okayP_291X) {
+    arg0K0 = temp0_292X;
+    arg0K1 = temp1_293X;
+    goto L14381;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = temp0_292X;
+    arg0K1 = temp1_293X;
+    goto L14381;}}
+ L15471: {
+  symbols_294X = arg0K0;
+  n_295X = (((3 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + symbols_294X))) + -4))))>>8))))>>2);
+  arg0K0 = 0;
+  goto L15538;}
+ L14381: {
+  imported_bindings_296X = arg0K0;
+  exported_bindings_297X = arg0K1;
+  if ((1 == imported_bindings_296X)) {
+    addr_298X = ALLOCATE_SPACE(2, 4100);
+    *((long *) addr_298X) = 1048586;
+    table_299X = 3 + (((long) (addr_298X + 4)));
+    arg0K0 = 0;
+    goto L14482;}
+  else {
+    arg0K0 = imported_bindings_296X;
+    goto L14396;}}
+ L15538: {
+  i_300X = arg0K0;
+  if ((i_300X == n_295X)) {
+    goto L15834;}
+  else {
+    table_301X = Sthe_symbol_tableS;
+    foo_302X = *((long *) ((((char *) (-3 + symbols_294X))) + (((i_300X)<<2))));
+    string_303X = *((long *) (((char *) (-3 + foo_302X))));
+    n_304X = -1 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + string_303X))) + -4))))>>8));
+    arg0K0 = 0;
+    arg0K1 = 0;
+    goto L13005;}}
+ L14482: {
+  i_305X = arg0K0;
+  if ((1024 == i_305X)) {
+    arg0K0 = table_299X;
+    goto L14396;}
+  else {
+    addr_306X = (((char *) (-3 + table_299X))) + (((i_305X)<<2));
+    S48_WRITE_BARRIER(table_299X, addr_306X, 1);
+    *((long *) addr_306X) = 1;
+    arg0K0 = (1 + i_305X);
+    goto L14482;}}
+ L14396: {
+  v_307X = arg0K0;
+  Simported_bindingsS = v_307X;
+  if ((1 == exported_bindings_297X)) {
+    addr_308X = ALLOCATE_SPACE(2, 4100);
+    *((long *) addr_308X) = 1048586;
+    table_309X = 3 + (((long) (addr_308X + 4)));
+    arg0K0 = 0;
+    goto L14459;}
+  else {
+    arg0K0 = exported_bindings_297X;
+    goto L14409;}}
+ L13005: {
+  i_310X = arg0K0;
+  h_311X = arg0K1;
+  if ((i_310X < n_304X)) {
+    arg0K0 = (1 + i_310X);
+    arg0K1 = (h_311X + (((*((unsigned char *) ((((char *) (-3 + string_303X))) + i_310X))))));
+    goto L13005;}
+  else {
+    index_312X = 1023 & h_311X;
+    val_313X = *((long *) ((((char *) (-3 + table_301X))) + (((index_312X)<<2))));
+    addr_314X = (((char *) (-3 + foo_302X))) + 4;
+    S48_WRITE_BARRIER(foo_302X, addr_314X, val_313X);
+    *((long *) addr_314X) = val_313X;
+    addr_315X = (((char *) (-3 + table_301X))) + (((index_312X)<<2));
+    S48_WRITE_BARRIER(table_301X, addr_315X, foo_302X);
+    *((long *) addr_315X) = foo_302X;
+    arg0K0 = (1 + i_300X);
+    goto L15538;}}
+ L14459: {
+  i_316X = arg0K0;
+  if ((1024 == i_316X)) {
+    arg0K0 = table_309X;
+    goto L14409;}
+  else {
+    addr_317X = (((char *) (-3 + table_309X))) + (((i_316X)<<2));
+    S48_WRITE_BARRIER(table_309X, addr_317X, 1);
+    *((long *) addr_317X) = 1;
+    arg0K0 = (1 + i_316X);
+    goto L14459;}}
+ L14409: {
+  v_318X = arg0K0;
+  Sexported_bindingsS = v_318X;
+  if ((stack_size_273X < 8131)) {
+    stack_319X = (char *)malloc(32524);
+    if ((stack_319X == NULL)) {
+      ps_error("out of memory, unable to continue", 0);
+      arg1K0 = stack_319X;
+      arg0K1 = 8131;
+      goto L14928;}
+    else {
+      arg1K0 = stack_319X;
+      arg0K1 = 8131;
+      goto L14928;}}
+  else {
+    arg1K0 = stack_begin_272X;
+    arg0K1 = stack_size_273X;
+    goto L14928;}}
+ L14928: {
+  start_320X = arg1K0;
+  size_321X = arg0K1;
+  Sstack_beginS = start_320X;
+  Sstack_endS = (start_320X + (((size_321X)<<2)));
+  Sstack_limitS = ((Sstack_beginS) + 524);
+  SstackS = ((Sstack_endS) + -4);
+  ScontS = 1;
+  SenvS = 17;
+  arg1K0 = start_320X;
+  goto L14960;}
+ L14960: {
+  a_322X = arg1K0;
+  if ((a_322X == (Sstack_endS))) {
+    v_323X = AVAILABLEp(5);
+    if (v_323X) {
+      goto L14977;}
+    else {
+      collect_saving_temps(1, 1, &temp1_324X);
+      v_325X = AVAILABLEp(5);
+      if (v_325X) {
+        goto L14977;}
+      else {
+        ps_error("Scheme48 heap overflow", 0);
+        goto L14977;}}}
+  else {
+    *((long *) a_322X) = 252645135;
+    arg1K0 = (a_322X + 4);
+    goto L14960;}}
+ L14977: {
+  addr_326X = ALLOCATE_SPACE(17, 6);
+  *((long *) addr_326X) = 582;
+  addr_327X = ALLOCATE_SPACE(11, 12);
+  *((long *) addr_327X) = 2094;
+  temp_328X = 3 + (((long) (addr_327X + 4)));
+  code_329X = 3 + (((long) (addr_326X + 4)));
+  addr_330X = ((char *) (-3 + temp_328X));
+  S48_WRITE_BARRIER(temp_328X, addr_330X, code_329X);
+  *((long *) addr_330X) = code_329X;
+  *((unsigned char *) (((char *) (-3 + code_329X)))) = 23;
+  *((unsigned char *) ((((char *) (-3 + code_329X))) + 1)) = 31;
+  SstackS = ((SstackS) + -20);
+  *((long *) ((SstackS) + 4)) = 4262;
+  cont_331X = 3 + (((long) ((SstackS) + 8)));
+  *((long *) ((((char *) (-3 + cont_331X))) + 4)) = 0;
+  *((long *) ((((char *) (-3 + cont_331X))) + 8)) = temp_328X;
+  *((long *) ((((char *) (-3 + cont_331X))) + 12)) = (SenvS);
+  *((long *) (((char *) (-3 + cont_331X)))) = (ScontS);
+  ScontS = cont_331X;
+  Sbottom_of_stackS = (ScontS);
+  v_332X = AVAILABLEp(5);
+  if (v_332X) {
+    goto L15156;}
+  else {
+    collect_saving_temps(1, 1, &temp1_333X);
+    v_334X = AVAILABLEp(5);
+    if (v_334X) {
+      goto L15156;}
+    else {
+      ps_error("Scheme48 heap overflow", 0);
+      goto L15156;}}}
+ L15156: {
+  addr_335X = ALLOCATE_SPACE(17, 6);
+  *((long *) addr_335X) = 582;
+  addr_336X = ALLOCATE_SPACE(11, 12);
+  *((long *) addr_336X) = 2094;
+  temp_337X = 3 + (((long) (addr_336X + 4)));
+  code_338X = 3 + (((long) (addr_335X + 4)));
+  addr_339X = ((char *) (-3 + temp_337X));
+  S48_WRITE_BARRIER(temp_337X, addr_339X, code_338X);
+  *((long *) addr_339X) = code_338X;
+  *((unsigned char *) (((char *) (-3 + code_338X)))) = 34;
+  *((unsigned char *) ((((char *) (-3 + code_338X))) + 1)) = 140;
+  Sinterrupt_templateS = temp_337X;
+  addr_340X = ALLOCATE_SPACE(17, 6);
+  *((long *) addr_340X) = 582;
+  addr_341X = ALLOCATE_SPACE(11, 12);
+  *((long *) addr_341X) = 2094;
+  temp_342X = 3 + (((long) (addr_341X + 4)));
+  code_343X = 3 + (((long) (addr_340X + 4)));
+  addr_344X = ((char *) (-3 + temp_342X));
+  S48_WRITE_BARRIER(temp_342X, addr_344X, code_343X);
+  *((long *) addr_344X) = code_343X;
+  *((unsigned char *) (((char *) (-3 + code_343X)))) = 137;
+  *((unsigned char *) ((((char *) (-3 + code_343X))) + 1)) = 123;
+  Sexception_templateS = temp_342X;
+  return;}
+}
+long s48_restart(long proc_345X, long nargs_346X)
+{
+  char * arg1K1;
+  char * arg1K0;
+  char *arg3K0;
+  char arg2K3;
+  char arg2K1;
+  char arg2K2;
+  char arg2K0;
+  long arg0K3;
+  long arg0K2;
+  long arg0K1;
+  long arg0K0;
+  char *merged_arg3K0;
+  long merged_arg0K3;
+  long merged_arg0K2;
+  long merged_arg0K1;
+  long merged_arg0K0;
+
+  int pop_continuationB_return_tag;
+  int get_error_string_return_tag;
+  long get_error_string0_return_value;
+  int okay_argument_list_return_tag;
+  char okay_argument_list0_return_value;
+  long okay_argument_list1_return_value;
+  int get_current_port_return_tag;
+  long get_current_port0_return_value;
+  int copy_continuation_from_heapB_return_tag;
+  long copy_continuation_from_heapB0_return_value;
+  int copy_listS_return_tag;
+  long copy_listS0_return_value;
+  int pop_args_GlistS_return_tag;
+  long pop_args_GlistS0_return_value;
+  int save_env_in_heap_return_tag;
+  long save_env_in_heap0_return_value;
+  int copy_env_return_tag;
+  long copy_env0_return_value;
+  int really_preserve_continuation_return_tag;
+  long really_preserve_continuation0_return_value;
+  int copy_stack_into_heap_return_tag;
+  int push_list_return_tag;
+  long push_list0_return_value;
+  int rest_list_setup_return_tag;
+  int check_events_return_tag;
+  char check_events0_return_value;
+  int loseD0_return_tag;
+  long status_347X;
+  long list_348X;
+  long marker_349X;
+  long cont_350X;
+  long list_351X;
+  long length_352X;
+  long start_353X;
+  long count_354X;
+  long env_355X;
+  long cont_356X;
+  long key_357X;
+  long reason_358X;
+  long env_359X;
+  long key_360X;
+  long reason_361X;
+  long key_362X;
+  long list_363X;
+  long count_364X;
+  long wants_stack_args_365X;
+  long stack_arg_count_366X;
+  long list_args_367X;
+  long list_arg_count_368X;
+  char *message_369X;
+  long pc_1284X;
+  long tem_1283X;
+  long cont_1282X;
+  long i_1281X;
+  long string_1280X;
+  char * addr_1279X;
+  long len_1278X;
+  long len_1277X;
+  long x_1276X;
+  char *string_1275X;
+  char move_slowP_1274X;
+  long slow_1273X;
+  long len_1272X;
+  long fast_1271X;
+  long v_1270X;
+  char *v_1269X;
+  long v_1268X;
+  long v_1267X;
+  long obj_1266X;
+  long env_1265X;
+  long thread_1264X;
+  long v_1263X;
+  long new_cont_1262X;
+  char * top_1261X;
+  char * addr_1260X;
+  long x_1259X;
+  char * addr_1258X;
+  long a_1257X;
+  long last_1256X;
+  long l_1255X;
+  long x_1254X;
+  char * addr_1253X;
+  long a_1252X;
+  long list_1251X;
+  long temp_1250X;
+  char okayP_1249X;
+  char v_1248X;
+  long temp1_1247X;
+  long temp0_1246X;
+  char v_1245X;
+  long space_1244X;
+  long x_1243X;
+  char * addr_1242X;
+  long a_1241X;
+  long count_1240X;
+  long args_1239X;
+  long start_1238X;
+  long temp_1237X;
+  char okayP_1236X;
+  char v_1235X;
+  long temp1_1234X;
+  long temp0_1233X;
+  char v_1232X;
+  long space_1231X;
+  long env_1230X;
+  long cont_1229X;
+  char * addr_1228X;
+  long new_1227X;
+  long p_1226X;
+  long env_1225X;
+  long top_1224X;
+  char * addr_1223X;
+  long new_1222X;
+  char * data_addr_1221X;
+  char * addr_1220X;
+  long header_1219X;
+  long new_1218X;
+  char * data_addr_1217X;
+  char * addr_1216X;
+  long header_1215X;
+  long p_1214X;
+  long previous_1213X;
+  long cont_1212X;
+  long end_1211X;
+  long v_1210X;
+  long p_1209X;
+  char * arg_1208X;
+  char * loc_1207X;
+  long stob_1206X;
+  char * top_1205X;
+  long arg_count_1204X;
+  long i_1203X;
+  char * p_1202X;
+  long v_1201X;
+  long l_1200X;
+  long i_1199X;
+  long key_1198X;
+  char okayP_1197X;
+  long list_1196X;
+  char v_1195X;
+  long temp1_1194X;
+  char v_1193X;
+  long space_1192X;
+  long x_1191X;
+  long v_1190X;
+  long x_1189X;
+  long v_1188X;
+  long count_1187X;
+  long x_1186X;
+  long v_1185X;
+  long status_1184X;
+  long channel_1183X;
+  long type_1182X;
+  char v_1181X;
+  long template_1180X;
+  char not_firstP_1179X;
+  long cont_1178X;
+  char not_firstP_1177X;
+  FILE * out_1176X;
+  long current_template_1175X;
+  long why_1174X;
+  long x_1173X;
+  long x_1172X;
+  long x_1171X;
+  char * addr_1170X;
+  long status_1169X;
+  char pendingP_1168X;
+  char eofP_1167X;
+  long got_1166X;
+  long length_1165X;
+  long v_1164X;
+  long obj_1163X;
+  long reason_1162X;
+  long status_1161X;
+  long v_1160X;
+  long v_1159X;
+  long key_1158X;
+  char okayP_1157X;
+  char v_1156X;
+  char * addr_1155X;
+  long value_1154X;
+  long offset_1153X;
+  long i_1152X;
+  long count_1151X;
+  long y_1150X;
+  char * addr_1149X;
+  long val_1148X;
+  char * addr_1147X;
+  long value_1146X;
+  long len_1145X;
+  long s2_1144X;
+  long foo_1143X;
+  long previous_foo_1142X;
+  long val_1141X;
+  long x_1140X;
+  char * addr_1139X;
+  long status_1138X;
+  char pendingP_1137X;
+  long got_1136X;
+  long length_1135X;
+  long count_1134X;
+  long start_1133X;
+  char waitP_1132X;
+  long x_1131X;
+  long status_1130X;
+  long channel_1129X;
+  long v_1128X;
+  long v_1127X;
+  long v_1126X;
+  long reason_1125X;
+  long channel_1124X;
+  long index_1123X;
+  long val_1122X;
+  long final_stack_arg_count_1121X;
+  char v_1120X;
+  long temp1_1119X;
+  char v_1118X;
+  long space_1117X;
+  long stack_arg_count_1116X;
+  long stack_slots_1115X;
+  char x_1114X;
+  long channel_1113X;
+  long obj_1112X;
+  long arg_count_1111X;
+  long count_1110X;
+  long i_1109X;
+  long env_1108X;
+  long value_1107X;
+  char *v_1106X;
+  long y_1105X;
+  long i_1104X;
+  long l_1103X;
+  long bucket_1102X;
+  long index_1101X;
+  long h_1100X;
+  long i_1099X;
+  long v_1098X;
+  long v_1097X;
+  long x_1096X;
+  long status_1095X;
+  long reason_1094X;
+  long v_1093X;
+  long reason_1092X;
+  long x_1091X;
+  long obj_1090X;
+  long v_1089X;
+  long v_1088X;
+  long len_1087X;
+  long s2_1086X;
+  char * addr_1085X;
+  long x_1084X;
+  char * addr_1083X;
+  long foo_1082X;
+  long rest_list_1081X;
+  long i_1080X;
+  long n_1079X;
+  long args_1078X;
+  long skip_1077X;
+  long template_1076X;
+  long stack_arg_count_1075X;
+  long skip_1074X;
+  long skip_1073X;
+  long template_1072X;
+  long stack_arg_count_1071X;
+  long skip_1070X;
+  char * addr_1069X;
+  long next_1068X;
+  long channel_1067X;
+  long m_1066X;
+  long i_1065X;
+  long value_1064X;
+  long back_1063X;
+  long env_1062X;
+  long offset_1061X;
+  long i_1060X;
+  long x_1059X;
+  char * addr_1058X;
+  long a_1057X;
+  long env_1056X;
+  long v_1055X;
+  long p_1054X;
+  long key_1053X;
+  long string_1052X;
+  char * addr_1051X;
+  long len_1050X;
+  long n_1049X;
+  long table_1048X;
+  long x_1047X;
+  long arg2_1046X;
+  long key_1045X;
+  char temp_1044X;
+  char minutesP_1043X;
+  long status_1042X;
+  long status_1041X;
+  long undumpable_count_1040X;
+  long undumpables_1039X;
+  long status_1038X;
+  long status_1037X;
+  long status_1036X;
+  long status_1035X;
+  FILE * port_1034X;
+  char x_1033X;
+  long comment_string_1032X;
+  long obj_1031X;
+  long arg3_1030X;
+  long arg2_1029X;
+  long key_1028X;
+  long x_1027X;
+  char * addr_1026X;
+  long channel_1025X;
+  long res_1024X;
+  long i_1023X;
+  char * addr_1022X;
+  char * addr_1021X;
+  long val_1020X;
+  char v_1019X;
+  long channel_1018X;
+  long count_1017X;
+  long start_1016X;
+  long obj_1015X;
+  long arg4_1014X;
+  long arg3_1013X;
+  long arg2_1012X;
+  long key_1011X;
+  long arg5_1010X;
+  long arg4_1009X;
+  long arg3_1008X;
+  long arg2_1007X;
+  long key_1006X;
+  long x_1005X;
+  long status_1004X;
+  long channel_1003X;
+  long obj_1002X;
+  long key_1001X;
+  long mode_1000X;
+  long arg2_999X;
+  long key_998X;
+  long bucket_997X;
+  long index_996X;
+  long h_995X;
+  long i_994X;
+  long i_993X;
+  long i_992X;
+  char * addr_991X;
+  long i_990X;
+  long i_989X;
+  long i_988X;
+  long c_987X;
+  long b_986X;
+  long c_985X;
+  long b_984X;
+  char x_983X;
+  long c_982X;
+  long b_981X;
+  long c_980X;
+  long mid_c_979X;
+  long v_978X;
+  long v_977X;
+  long lo_c_976X;
+  long hi_b_975X;
+  long hi_a_974X;
+  long lo_b_973X;
+  long lo_a_972X;
+  long b_971X;
+  long v_970X;
+  long v_969X;
+  long args_968X;
+  long next_967X;
+  long next_op_966X;
+  long cont_965X;
+  long index_964X;
+  long length_963X;
+  long wants_stack_args_962X;
+  long skip_961X;
+  long skip_960X;
+  long stack_space_959X;
+  long protocol_958X;
+  long index_957X;
+  long length_956X;
+  long wants_stack_args_955X;
+  long skip_954X;
+  long skip_953X;
+  long stack_space_952X;
+  long protocol_951X;
+  long n_950X;
+  long tem_949X;
+  long stack_arg_count_948X;
+  long v_947X;
+  long v_946X;
+  long key_945X;
+  long start_i_944X;
+  long temp_943X;
+  char okayP_942X;
+  long key_941X;
+  char okayP_940X;
+  long obj_939X;
+  long obj_938X;
+  long type_937X;
+  long thing_936X;
+  long stuff_935X;
+  char * addr_934X;
+  long val_933X;
+  long x_932X;
+  long i_931X;
+  long b_930X;
+  long p_929X;
+  long port_928X;
+  long Kchar_927X;
+  long x_926X;
+  long i_925X;
+  long b_924X;
+  long p_923X;
+  long p_922X;
+  long port_921X;
+  char * addr_920X;
+  long val_919X;
+  long x_918X;
+  long i_917X;
+  long b_916X;
+  long p_915X;
+  long p_914X;
+  long port_913X;
+  long list_912X;
+  long head_911X;
+  char move_slowP_910X;
+  long slow_909X;
+  long list_908X;
+  long n_907X;
+  long arg2_906X;
+  long val_905X;
+  long mseconds_904X;
+  long seconds_903X;
+  long option_902X;
+  long key_901X;
+  char okayP_900X;
+  long result_899X;
+  char * args_898X;
+  long name_897X;
+  long proc_896X;
+  long rest_list_895X;
+  long x_894X;
+  long tem_893X;
+  long pc_892X;
+  long v_891X;
+  long value_890X;
+  long vector_889X;
+  long type_888X;
+  char firstP_887X;
+  long v_886X;
+  long vector_885X;
+  char firstP_884X;
+  long x_883X;
+  char * addr_882X;
+  long b_881X;
+  long x_880X;
+  char * addr_879X;
+  long proc_878X;
+  long stob_877X;
+  long h_876X;
+  long i_875X;
+  long key_874X;
+  char okayP_873X;
+  long y_872X;
+  long n_871X;
+  char * addr_870X;
+  long prev_869X;
+  long ch_868X;
+  long val_867X;
+  long key_866X;
+  char okayP_865X;
+  long key_864X;
+  char okayP_863X;
+  long key_862X;
+  char okayP_861X;
+  long key_860X;
+  char okayP_859X;
+  long val_858X;
+  char * addr_857X;
+  char * addr_856X;
+  long val_855X;
+  long n_854X;
+  long string_853X;
+  long table_852X;
+  long obj_851X;
+  long string_850X;
+  char * addr_849X;
+  long len_848X;
+  long vector_847X;
+  char * addr_846X;
+  long value_845X;
+  char * addr_844X;
+  long len_843X;
+  long init_842X;
+  char okayP_841X;
+  long rest_list_840X;
+  long stack_nargs_839X;
+  long new_838X;
+  char * addr_837X;
+  long len_836X;
+  long type_835X;
+  long new_834X;
+  char * addr_833X;
+  long len_832X;
+  long type_831X;
+  long value_830X;
+  long val_829X;
+  long val_828X;
+  long val_827X;
+  long val_826X;
+  long r_825X;
+  long n_824X;
+  long a_823X;
+  long a_822X;
+  long val_821X;
+  long val_820X;
+  long val_819X;
+  long val_818X;
+  long val_817X;
+  long a_816X;
+  long a_815X;
+  long val_814X;
+  long val_813X;
+  long delta_812X;
+  long delta_811X;
+  long offset_810X;
+  long key_809X;
+  char okayP_808X;
+  char v_807X;
+  long tem_806X;
+  long key_805X;
+  char okayP_804X;
+  long list_arg_count_803X;
+  long list_args_802X;
+  long stack_nargs_801X;
+  long obj_800X;
+  char * addr_799X;
+  long list_args_798X;
+  long follower_797X;
+  long list_796X;
+  long args_795X;
+  long list_arg_count_794X;
+  char okayP_793X;
+  long stack_nargs_792X;
+  long list_args_791X;
+  long total_arg_count_790X;
+  long code_789X;
+  long obj_788X;
+  long obj_787X;
+  long list_arg_count_786X;
+  long list_args_785X;
+  long stack_arg_count_784X;
+  long obj_783X;
+  char * arg_782X;
+  char * loc_781X;
+  long args_780X;
+  long v_779X;
+  long v_778X;
+  long v_777X;
+  long list_arg_count_776X;
+  long list_args_775X;
+  long stack_arg_count_774X;
+  long exception_773X;
+  long code_772X;
+  long stack_arg_count_771X;
+  char v_770X;
+  long key_769X;
+  char okayP_768X;
+  long key_767X;
+  char okayP_766X;
+  char * addr_765X;
+  long value_764X;
+  long v_763X;
+  long new_env_762X;
+  char * addr_761X;
+  long len_760X;
+  char v_759X;
+  long temp1_758X;
+  long temp0_757X;
+  char v_756X;
+  long env_755X;
+  char v_754X;
+  long temp1_753X;
+  char v_752X;
+  long space_751X;
+  char * addr_750X;
+  long value_749X;
+  long index_748X;
+  long i_747X;
+  long env_746X;
+  long i_745X;
+  long env_744X;
+  long i_743X;
+  long env_742X;
+  long obj_741X;
+  long opcode_740X;
+  long nargs_739X;
+  FILE * out_738X;
+  long x_737X;
+  long v_736X;
+  long v_735X;
+  long v_734X;
+  long v_733X;
+  long v_732X;
+  long v_731X;
+  long v_730X;
+  long count_729X;
+  long to_index_728X;
+  long from_index_727X;
+  long arg5_726X;
+  long arg4_725X;
+  long arg3_724X;
+  long arg2_723X;
+  char * addr_722X;
+  long len_721X;
+  long value_720X;
+  long index_719X;
+  long arg4_718X;
+  long arg3_717X;
+  long arg2_716X;
+  long len_715X;
+  long index_714X;
+  long arg3_713X;
+  long arg2_712X;
+  long list_711X;
+  long thing_710X;
+  char v_709X;
+  long temp1_708X;
+  char v_707X;
+  long space_706X;
+  long len_705X;
+  long x_704X;
+  long obj_703X;
+  long arg2_702X;
+  long x_701X;
+  long arg2_700X;
+  long status_699X;
+  long value_698X;
+  long key_697X;
+  long arg2_696X;
+  long mseconds_695X;
+  long seconds_694X;
+  long mseconds_693X;
+  long seconds_692X;
+  long x_691X;
+  long other_690X;
+  long option_689X;
+  long arg2_688X;
+  long x_687X;
+  long arg2_686X;
+  char v_685X;
+  long temp1_684X;
+  char v_683X;
+  long rest_list_682X;
+  long p_681X;
+  long nargs_680X;
+  long x_679X;
+  long arg2_678X;
+  long p_677X;
+  long p_676X;
+  long p_675X;
+  long old_674X;
+  long temp_673X;
+  long obj_672X;
+  long p_671X;
+  long template_670X;
+  long p_669X;
+  long temp_668X;
+  long obj_667X;
+  long x_666X;
+  long type_665X;
+  long x_664X;
+  long bytes_663X;
+  long x_662X;
+  long other_661X;
+  long key_660X;
+  long arg2_659X;
+  char v_658X;
+  long temp1_657X;
+  char v_656X;
+  long n_655X;
+  long x_654X;
+  long obj_653X;
+  long v_652X;
+  char v_651X;
+  long temp1_650X;
+  char v_649X;
+  long x_648X;
+  char v_647X;
+  long temp1_646X;
+  char v_645X;
+  long space_644X;
+  char * addr_643X;
+  long next_642X;
+  long channel_641X;
+  long n_640X;
+  char * addr_639X;
+  long head_638X;
+  long channel_637X;
+  long obj_636X;
+  char v_635X;
+  long temp1_634X;
+  char v_633X;
+  char v_632X;
+  long temp1_631X;
+  char v_630X;
+  char v_629X;
+  long temp1_628X;
+  char v_627X;
+  char v_626X;
+  long temp1_625X;
+  char v_624X;
+  long x_623X;
+  long x_622X;
+  long x_621X;
+  long arg2_620X;
+  long descriptor_619X;
+  long x_618X;
+  long obj_617X;
+  char v_616X;
+  long temp1_615X;
+  char v_614X;
+  long len_613X;
+  char Kchar_612X;
+  long index_611X;
+  long arg3_610X;
+  long arg2_609X;
+  long len_608X;
+  long index_607X;
+  long arg2_606X;
+  long obj_605X;
+  char v_604X;
+  long temp1_603X;
+  char v_602X;
+  long size_601X;
+  char init_600X;
+  long len_599X;
+  long arg2_598X;
+  long len_597X;
+  long Kchar_596X;
+  long index_595X;
+  long arg3_594X;
+  long arg2_593X;
+  long len_592X;
+  long index_591X;
+  long arg2_590X;
+  long obj_589X;
+  char v_588X;
+  long temp1_587X;
+  char v_586X;
+  long size_585X;
+  long init_584X;
+  long len_583X;
+  long arg2_582X;
+  char * addr_581X;
+  long index_580X;
+  long len_579X;
+  long type_578X;
+  long value_577X;
+  long stob_576X;
+  long arg2_575X;
+  long index_574X;
+  long len_573X;
+  long type_572X;
+  long index_571X;
+  long stob_570X;
+  char v_569X;
+  long temp1_568X;
+  long temp0_567X;
+  char v_566X;
+  long size_565X;
+  long len_564X;
+  long type_563X;
+  long init_562X;
+  long len_561X;
+  char * addr_560X;
+  long type_559X;
+  long offset_558X;
+  long value_557X;
+  long stob_556X;
+  long type_555X;
+  long offset_554X;
+  long stob_553X;
+  char v_552X;
+  long temp1_551X;
+  char v_550X;
+  long space_549X;
+  long len_548X;
+  char v_547X;
+  long temp1_546X;
+  char v_545X;
+  long space_544X;
+  long len_543X;
+  long type_542X;
+  long stob_541X;
+  long type_540X;
+  long x_539X;
+  long x_538X;
+  long x_537X;
+  long x_536X;
+  long arg2_535X;
+  long x_534X;
+  long arg2_533X;
+  long x_532X;
+  long x_531X;
+  long result_530X;
+  long x_529X;
+  long x_528X;
+  long count_527X;
+  long value_526X;
+  long y_525X;
+  long x_524X;
+  long x_523X;
+  long arg2_522X;
+  long x_521X;
+  long arg2_520X;
+  long x_519X;
+  long arg2_518X;
+  long x_517X;
+  long x_516X;
+  long arg2_515X;
+  long x_514X;
+  long arg2_513X;
+  long x_512X;
+  long arg2_511X;
+  long n_510X;
+  long n_509X;
+  long x_508X;
+  long x_507X;
+  long x_506X;
+  long x_505X;
+  long x_504X;
+  long x_503X;
+  long x_502X;
+  long x_501X;
+  long x_500X;
+  long x_499X;
+  long x_498X;
+  long x_497X;
+  long x_496X;
+  long x_495X;
+  long a_494X;
+  long y_493X;
+  long x_492X;
+  long b_491X;
+  long a_490X;
+  long x_489X;
+  long arg2_488X;
+  long x_487X;
+  long arg2_486X;
+  long x_485X;
+  long arg2_484X;
+  long x_483X;
+  long arg2_482X;
+  long x_481X;
+  long arg2_480X;
+  long x_479X;
+  long arg2_478X;
+  long b_477X;
+  long a_476X;
+  long x_475X;
+  long arg2_474X;
+  long z_473X;
+  long y_472X;
+  long x_471X;
+  long b_470X;
+  long a_469X;
+  long x_468X;
+  long arg2_467X;
+  long z_466X;
+  long y_465X;
+  long x_464X;
+  long x_463X;
+  long x_462X;
+  long x_461X;
+  long n_460X;
+  long n_459X;
+  long n_458X;
+  long n_457X;
+  long x_456X;
+  long x_455X;
+  long arg2_454X;
+  long rest_list_453X;
+  long x_452X;
+  long rest_list_451X;
+  long stack_nargs_450X;
+  long arg0_449X;
+  long arg1_448X;
+  long rest_list_447X;
+  long arg0_446X;
+  long stack_nargs_445X;
+  long index_444X;
+  long val_443X;
+  long max_442X;
+  long p_441X;
+  char v_440X;
+  long temp1_439X;
+  char v_438X;
+  long space_437X;
+  long space_436X;
+  long index_435X;
+  long v_434X;
+  char v_433X;
+  long temp1_432X;
+  char v_431X;
+  long space_430X;
+  long code_429X;
+  long tem_428X;
+  long stack_nargs_427X;
+  long p_426X;
+  long obj_425X;
+  long consumer_424X;
+  long cont_423X;
+  long rest_list_422X;
+  long proc_421X;
+  long stack_nargs_420X;
+  long args_419X;
+  long length_418X;
+  char okayP_417X;
+  long list_args_416X;
+  long stob_415X;
+  char * top_of_args_414X;
+  long nargs_413X;
+  long obj_412X;
+  long stack_arg_count_411X;
+  char v_410X;
+  long temp1_409X;
+  char v_408X;
+  long space_407X;
+  long code_406X;
+  long template_405X;
+  long obj_404X;
+  long stack_arg_count_403X;
+  long cont_402X;
+  char v_401X;
+  long temp1_400X;
+  char v_399X;
+  long space_398X;
+  char v_397X;
+  long temp1_396X;
+  char v_395X;
+  long space_394X;
+  long total_count_393X;
+  long p_392X;
+  long v_391X;
+  char * addr_390X;
+  long val_389X;
+  long location_388X;
+  long location_387X;
+  long env_386X;
+  long back_385X;
+  long env_384X;
+  long back_383X;
+  long env_382X;
+  long back_381X;
+  long count_380X;
+  char * code_pointer_379X;
+  long code_378X;
+  char * addr_377X;
+  long proc_376X;
+  long temp_375X;
+  char okayP_374X;
+  char v_373X;
+  long temp1_372X;
+  long temp0_371X;
+  char v_370X;
+ {  v_370X = AVAILABLEp(2);
+  if (v_370X) {
+    arg2K0 = 1;
+    arg0K1 = proc_345X;
+    goto L19375;}
+  else {
+    temp0_371X = collect_saving_temps(proc_345X, 1, &temp1_372X);
+    v_373X = AVAILABLEp(2);
+    if (v_373X) {
+      arg2K0 = 1;
+      arg0K1 = temp0_371X;
+      goto L19375;}
+    else {
+      arg2K0 = 0;
+      arg0K1 = temp0_371X;
+      goto L19375;}}}
+ L19375: {
+  okayP_374X = arg2K0;
+  temp_375X = arg0K1;
+  if (okayP_374X) {
+    arg0K0 = temp_375X;
+    goto L19346;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = temp_375X;
+    goto L19346;}}
+ L19346: {
+  proc_376X = arg0K0;
+  addr_377X = ALLOCATE_SPACE(17, 6);
+  *((long *) addr_377X) = 582;
+  code_378X = 3 + (((long) (addr_377X + 4)));
+  *((unsigned char *) (((char *) (-3 + code_378X)))) = 24;
+  *((unsigned char *) ((((char *) (-3 + code_378X))) + 1)) = nargs_346X;
+  Scode_pointerS = (((char *) (-3 + code_378X)));
+  SvalS = proc_376X;
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L18438: {
+  code_pointer_379X = arg1K0;
+  switch ((*((unsigned char *) code_pointer_379X))) {
+    case 0 : 
+    case 145 : {
+      push_exception_continuationB(15, 1);
+      arg0K0 = 0;
+      goto L16665;}
+      break;
+    case 1 : {
+      count_380X = ((((*((unsigned char *) ((Scode_pointerS) + 1))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + 2)));
+      *((long *) (SstackS)) = (SenvS);
+      SstackS = ((SstackS) + -4);
+      *((long *) (SstackS)) = (1034 + (((count_380X)<<10)));
+      SstackS = ((SstackS) + -4);
+      SenvS = (3 + (((long) ((SstackS) + 8))));
+      Scode_pointerS = ((Scode_pointerS) + 3);
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 2 : {
+      SvalS = (*((long *) ((((char *) (-3 + (StemplateS)))) + ((((((((*((unsigned char *) ((Scode_pointerS) + 1))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + 2)))))<<2)))));
+      Scode_pointerS = ((Scode_pointerS) + 3);
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 3 : {
+      SvalS = (*((long *) ((((char *) (-3 + (StemplateS)))) + ((((*((unsigned char *) ((Scode_pointerS) + 1))))<<2)))));
+      Scode_pointerS = ((Scode_pointerS) + 3);
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 4 : {
+      back_381X = *((unsigned char *) ((Scode_pointerS) + 1));
+      env_382X = SenvS;
+      arg0K0 = env_382X;
+      arg0K1 = back_381X;
+      goto L23824;}
+      break;
+    case 5 : {
+      SvalS = (*((long *) ((((char *) (-3 + (SenvS)))) + ((((*((unsigned char *) ((Scode_pointerS) + 1))))<<2)))));
+      if ((529 == (SvalS))) {
+        push_exception_continuationB(0, 2);
+        arg0K0 = 0;
+        goto L16665;}
+      else {
+        Scode_pointerS = ((Scode_pointerS) + 2);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}}
+      break;
+    case 6 : {
+      SvalS = (*((long *) ((((char *) (-3 + (*((long *) (((char *) (-3 + (SenvS))))))))) + ((((*((unsigned char *) ((Scode_pointerS) + 1))))<<2)))));
+      if ((529 == (SvalS))) {
+        push_exception_continuationB(0, 2);
+        arg0K0 = 0;
+        goto L16665;}
+      else {
+        Scode_pointerS = ((Scode_pointerS) + 2);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}}
+      break;
+    case 7 : {
+      SvalS = (*((long *) ((((char *) (-3 + (*((long *) (((char *) (-3 + (*((long *) (((char *) (-3 + (SenvS)))))))))))))) + ((((*((unsigned char *) ((Scode_pointerS) + 1))))<<2)))));
+      if ((529 == (SvalS))) {
+        push_exception_continuationB(0, 2);
+        arg0K0 = 0;
+        goto L16665;}
+      else {
+        Scode_pointerS = ((Scode_pointerS) + 2);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}}
+      break;
+    case 8 : {
+      back_383X = ((((*((unsigned char *) ((Scode_pointerS) + 1))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + 2)));
+      env_384X = SenvS;
+      arg0K0 = env_384X;
+      arg0K1 = back_383X;
+      goto L20247;}
+      break;
+    case 9 : {
+      back_385X = ((((*((unsigned char *) ((Scode_pointerS) + 1))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + 2)));
+      env_386X = SenvS;
+      arg0K0 = env_386X;
+      arg0K1 = back_385X;
+      goto L20185;}
+      break;
+    case 10 : {
+      location_387X = *((long *) ((((char *) (-3 + (StemplateS)))) + ((((((((*((unsigned char *) ((Scode_pointerS) + 1))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + 2)))))<<2))));
+      SvalS = (*((long *) ((((char *) (-3 + location_387X))) + 4)));
+      if ((17 == (255 & (SvalS)))) {
+        push_exception_continuationB(1, 3);
+        *((long *) (SstackS)) = location_387X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 1;
+        goto L16665;}
+      else {
+        Scode_pointerS = ((Scode_pointerS) + 3);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}}
+      break;
+    case 11 : {
+      location_388X = *((long *) ((((char *) (-3 + (StemplateS)))) + ((((((((*((unsigned char *) ((Scode_pointerS) + 1))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + 2)))))<<2))));
+      if ((273 == (*((long *) ((((char *) (-3 + location_388X))) + 4))))) {
+        push_exception_continuationB(1, 3);
+        *((long *) (SstackS)) = location_388X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = (SvalS);
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}
+      else {
+        val_389X = SvalS;
+        addr_390X = (((char *) (-3 + location_388X))) + 4;
+        S48_WRITE_BARRIER(location_388X, addr_390X, val_389X);
+        *((long *) addr_390X) = val_389X;
+        SvalS = 13;
+        Scode_pointerS = ((Scode_pointerS) + 3);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}}
+      break;
+    case 12 : {
+      v_391X = *((unsigned char *) ((Scode_pointerS) + 3));
+      if ((0 == v_391X)) {
+        p_392X = SenvS;
+        if ((3 == (3 & p_392X))) {
+          if ((p_392X < (((long) (Sstack_beginS))))) {
+            arg0K0 = 0;
+            goto L20964;}
+          else {
+            if (((((long) (Sstack_endS))) < p_392X)) {
+              arg0K0 = 0;
+              goto L20964;}
+            else {
+              arg0K0 = ((Sstack_endS) - (Sstack_beginS));
+              goto L20964;}}}
+        else {
+          arg0K0 = 0;
+          goto L20964;}}
+      else {
+        arg0K0 = (SvalS);
+        goto L20971;}}
+      break;
+    case 13 : {
+      total_count_393X = *((unsigned char *) ((Scode_pointerS) + 2));
+      space_394X = 1 + total_count_393X;
+      v_395X = AVAILABLEp(space_394X);
+      if (v_395X) {
+        goto L20766;}
+      else {
+        collect_saving_temps(1, 1, &temp1_396X);
+        v_397X = AVAILABLEp(space_394X);
+        if (v_397X) {
+          goto L20766;}
+        else {
+          ps_error("Scheme48 heap overflow", 0);
+          goto L20766;}}}
+      break;
+    case 14 : {
+      *((long *) (SstackS)) = (SvalS);
+      SstackS = ((SstackS) + -4);
+      Scode_pointerS = ((Scode_pointerS) + 1);
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 15 : {
+      SvalS = (*((long *) ((((char *) (-3 + (SenvS)))) + ((((*((unsigned char *) ((Scode_pointerS) + 1))))<<2)))));
+      if ((529 == (SvalS))) {
+        push_exception_continuationB(0, 3);
+        arg0K0 = 0;
+        goto L16665;}
+      else {
+        *((long *) (SstackS)) = (SvalS);
+        SstackS = ((SstackS) + -4);
+        Scode_pointerS = ((Scode_pointerS) + 3);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}}
+      break;
+    case 16 : {
+      *((long *) (SstackS)) = (SvalS);
+      SstackS = ((SstackS) + -4);
+      SvalS = (*((long *) ((((char *) (-3 + (SenvS)))) + ((((*((unsigned char *) ((Scode_pointerS) + 2))))<<2)))));
+      if ((529 == (SvalS))) {
+        push_exception_continuationB(0, 3);
+        arg0K0 = 0;
+        goto L16665;}
+      else {
+        Scode_pointerS = ((Scode_pointerS) + 3);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}}
+      break;
+    case 17 : {
+      SstackS = ((SstackS) + 4);
+      SvalS = (*((long *) (SstackS)));
+      Scode_pointerS = ((Scode_pointerS) + 1);
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 18 : {
+      SvalS = (*((long *) ((SstackS) + (4 + ((((*((unsigned char *) ((Scode_pointerS) + 1))))<<2))))));
+      Scode_pointerS = ((Scode_pointerS) + 2);
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 19 : {
+      *((long *) ((SstackS) + (4 + ((((*((unsigned char *) ((Scode_pointerS) + 1))))<<2))))) = (SvalS);
+      Scode_pointerS = ((Scode_pointerS) + 2);
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 20 : {
+      push_continuationB(((Scode_pointerS) + (((((*((unsigned char *) ((Scode_pointerS) + 1))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + 2))))), (*((unsigned char *) ((Scode_pointerS) + 3))));
+      Scode_pointerS = ((Scode_pointerS) + 4);
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 21 : {
+      push_continuationB(((Scode_pointerS) + (((((*((unsigned char *) ((Scode_pointerS) + 1))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + 2))))), (((((*((unsigned char *) ((Scode_pointerS) + 3))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + 4)))));
+      Scode_pointerS = ((Scode_pointerS) + 5);
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 22 : {
+      space_398X = 1 + (((((Sstack_endS) - (SstackS)))>>2));
+      v_399X = AVAILABLEp(space_398X);
+      if (v_399X) {
+        arg2K0 = 1;
+        arg0K1 = 0;
+        goto L20692;}
+      else {
+        collect_saving_temps(1, 1, &temp1_400X);
+        v_401X = AVAILABLEp(space_398X);
+        if (v_401X) {
+          arg2K0 = 1;
+          arg0K1 = 0;
+          goto L20692;}
+        else {
+          arg2K0 = 0;
+          arg0K1 = 0;
+          goto L20692;}}}
+      break;
+    case 23 : {
+      cont_402X = *((long *) (((char *) (-3 + (Sbottom_of_stackS)))));
+      if ((3 == (3 & cont_402X))) {
+        if ((9 == (31 & ((((*((long *) ((((char *) (-3 + cont_402X))) + -4))))>>2))))) {
+          if ((3 == (3 & cont_402X))) {
+            if ((9 == (31 & ((((*((long *) ((((char *) (-3 + cont_402X))) + -4))))>>2))))) {
+              merged_arg0K0 = cont_402X;
+              copy_continuation_from_heapB_return_tag = 0;
+              goto copy_continuation_from_heapB;
+             copy_continuation_from_heapB_return_0:
+              goto L19847;}
+            else {
+              goto L19882;}}
+          else {
+            goto L19882;}}
+        else {
+          goto L19848;}}
+      else {
+        goto L19848;}}
+      break;
+    case 24 : {
+      stack_arg_count_403X = *((unsigned char *) ((Scode_pointerS) + 1));
+      obj_404X = SvalS;
+      if ((3 == (3 & obj_404X))) {
+        if ((3 == (31 & ((((*((long *) ((((char *) (-3 + obj_404X))) + -4))))>>2))))) {
+          template_405X = *((long *) (((char *) (-3 + (SvalS)))));
+          code_406X = *((long *) (((char *) (-3 + template_405X))));
+          if ((stack_arg_count_403X == (*((unsigned char *) ((((char *) (-3 + code_406X))) + 1))))) {
+            StemplateS = template_405X;
+            SenvS = (*((long *) ((((char *) (-3 + (SvalS)))) + 4)));
+            Scode_pointerS = ((((char *) (-3 + code_406X))) + 2);
+            if (((SstackS) < (Sstack_limitS))) {
+              space_407X = 1 + (((((Sstack_endS) - (SstackS)))>>2));
+              v_408X = AVAILABLEp(space_407X);
+              if (v_408X) {
+                arg2K0 = 1;
+                arg0K1 = 0;
+                goto L19208;}
+              else {
+                collect_saving_temps(1, 1, &temp1_409X);
+                v_410X = AVAILABLEp(space_407X);
+                if (v_410X) {
+                  arg2K0 = 1;
+                  arg0K1 = 0;
+                  goto L19208;}
+                else {
+                  arg2K0 = 0;
+                  arg0K1 = 0;
+                  goto L19208;}}}
+            else {
+              goto L19120;}}
+          else {
+            arg0K0 = stack_arg_count_403X;
+            goto L16066;}}
+        else {
+          arg0K0 = 3;
+          arg0K1 = stack_arg_count_403X;
+          arg0K2 = 25;
+          arg0K3 = 0;
+          goto L17161;}}
+      else {
+        arg0K0 = 3;
+        arg0K1 = stack_arg_count_403X;
+        arg0K2 = 25;
+        arg0K3 = 0;
+        goto L17161;}}
+      break;
+    case 25 : {
+      stack_arg_count_411X = ((((*((unsigned char *) ((Scode_pointerS) + 1))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + 2)));
+      obj_412X = SvalS;
+      if ((3 == (3 & obj_412X))) {
+        if ((3 == (31 & ((((*((long *) ((((char *) (-3 + obj_412X))) + -4))))>>2))))) {
+          arg0K0 = stack_arg_count_411X;
+          goto L16066;}
+        else {
+          arg0K0 = 3;
+          arg0K1 = stack_arg_count_411X;
+          arg0K2 = 25;
+          arg0K3 = 0;
+          goto L17161;}}
+      else {
+        arg0K0 = 3;
+        arg0K1 = stack_arg_count_411X;
+        arg0K2 = 25;
+        arg0K3 = 0;
+        goto L17161;}}
+      break;
+    case 26 : {
+      nargs_413X = *((unsigned char *) ((Scode_pointerS) + 1));
+      top_of_args_414X = SstackS;
+      stob_415X = ScontS;
+      arg1K0 = ((((char *) (-3 + stob_415X))) + -8);
+      arg1K1 = (top_of_args_414X + (((nargs_413X)<<2)));
+      goto L17628;}
+      break;
+    case 27 : {
+      SstackS = ((SstackS) + 4);
+      list_args_416X = *((long *) (SstackS));
+      merged_arg0K0 = list_args_416X;
+      okay_argument_list_return_tag = 0;
+      goto okay_argument_list;
+     okay_argument_list_return_0:
+      okayP_417X = okay_argument_list0_return_value;
+      length_418X = okay_argument_list1_return_value;
+      if (okayP_417X) {
+        arg0K0 = (((((*((unsigned char *) ((Scode_pointerS) + 1))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + 2))));
+        arg0K1 = list_args_416X;
+        arg0K2 = length_418X;
+        goto L17666;}
+      else {
+        *((long *) (SstackS)) = list_args_416X;
+        SstackS = ((SstackS) + -4);
+        merged_arg0K0 = 25;
+        merged_arg0K1 = (1 + (((((*((unsigned char *) ((Scode_pointerS) + 1))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + 2)))));
+        pop_args_GlistS_return_tag = 0;
+        goto pop_args_GlistS;
+       pop_args_GlistS_return_0:
+        args_419X = pop_args_GlistS0_return_value;
+        push_exception_continuationB(5, 0);
+        *((long *) (SstackS)) = (SvalS);
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = args_419X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+      break;
+    case 28 : {
+      SstackS = ((SstackS) + 4);
+      SstackS = ((SstackS) + 4);
+      stack_nargs_420X = (((*((long *) (SstackS))))>>2);
+      proc_421X = *((long *) ((SstackS) + (4 + (((stack_nargs_420X)<<2)))));
+      *((long *) ((SstackS) + (4 + (((stack_nargs_420X)<<2))))) = 1;
+      SstackS = ((SstackS) + 4);
+      rest_list_422X = *((long *) (SstackS));
+      if ((25 == rest_list_422X)) {
+        SstackS = ((SstackS) + 4);
+        arg0K0 = (*((long *) (SstackS)));
+        arg0K1 = (-2 + stack_nargs_420X);
+        goto L11273;}
+      else {
+        if ((25 == (*((long *) ((((char *) (-3 + rest_list_422X))) + 4))))) {
+          arg0K0 = (*((long *) (((char *) (-3 + rest_list_422X)))));
+          arg0K1 = (-1 + stack_nargs_420X);
+          goto L11273;}
+        else {
+          arg0K0 = (*((long *) ((((char *) (-3 + (*((long *) ((((char *) (-3 + rest_list_422X))) + 4)))))) + 4)));
+          arg0K1 = rest_list_422X;
+          goto L11314;}}}
+      break;
+    case 29 : {
+      SstackS = ((SstackS) + 4);
+      cont_423X = *((long *) (SstackS));
+      if ((3 == (3 & cont_423X))) {
+        if ((9 == (31 & ((((*((long *) ((((char *) (-3 + cont_423X))) + -4))))>>2))))) {
+          merged_arg0K0 = cont_423X;
+          copy_continuation_from_heapB_return_tag = 1;
+          goto copy_continuation_from_heapB;
+         copy_continuation_from_heapB_return_1:
+          goto L17571;}
+        else {
+          goto L17578;}}
+      else {
+        goto L17578;}}
+      break;
+    case 30 : {
+      SstackS = ((SstackS) + 4);
+      consumer_424X = *((long *) (SstackS));
+      *((long *) (SstackS)) = (SvalS);
+      SstackS = ((SstackS) + -4);
+      SvalS = consumer_424X;
+      obj_425X = SvalS;
+      if ((3 == (3 & obj_425X))) {
+        if ((3 == (31 & ((((*((long *) ((((char *) (-3 + obj_425X))) + -4))))>>2))))) {
+          arg0K0 = 1;
+          goto L16066;}
+        else {
+          arg0K0 = 3;
+          arg0K1 = 1;
+          arg0K2 = 25;
+          arg0K3 = 0;
+          goto L17161;}}
+      else {
+        arg0K0 = 3;
+        arg0K1 = 1;
+        arg0K2 = 25;
+        arg0K3 = 0;
+        goto L17161;}}
+      break;
+    case 31 : {
+      pop_continuationB_return_tag = 0;
+      goto pop_continuationB;
+     pop_continuationB_return_0:
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 32 : {
+      arg0K0 = (((((*((unsigned char *) ((Scode_pointerS) + 1))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + 2))));
+      arg0K1 = 25;
+      arg0K2 = 0;
+      goto L20427;}
+      break;
+    case 33 : {
+      SstackS = ((SstackS) + 4);
+      p_426X = *((long *) (SstackS));
+      SstackS = ((SstackS) + 4);
+      stack_nargs_427X = (((*((long *) (SstackS))))>>2);
+      SstackS = ((SstackS) + 4);
+      arg0K0 = stack_nargs_427X;
+      arg0K1 = (*((long *) (SstackS)));
+      arg0K2 = ((((p_426X)>>2)) - stack_nargs_427X);
+      goto L20427;}
+      break;
+    case 34 : {
+      Scode_pointerS = ((Scode_pointerS) + 1);
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 35 : {
+      tem_428X = *((long *) ((((char *) (-3 + (StemplateS)))) + ((((((((*((unsigned char *) ((Scode_pointerS) + 1))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + 2)))))<<2))));
+      StemplateS = tem_428X;
+      Scode_pointerS = (((char *) (-3 + (*((long *) (((char *) (-3 + tem_428X))))))));
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 36 : {
+      code_429X = *((long *) (((char *) (-3 + (*((long *) ((((char *) (-3 + (StemplateS)))) + ((((((((*((unsigned char *) ((Scode_pointerS) + 1))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + 2)))))<<2)))))))));
+      if ((0 == (*((unsigned char *) ((((char *) (-3 + code_429X))) + 1))))) {
+        if (((SstackS) < (Sstack_limitS))) {
+          space_430X = 1 + (((((Sstack_endS) - (SstackS)))>>2));
+          v_431X = AVAILABLEp(space_430X);
+          if (v_431X) {
+            arg2K0 = 1;
+            arg0K1 = 0;
+            goto L18944;}
+          else {
+            collect_saving_temps(1, 1, &temp1_432X);
+            v_433X = AVAILABLEp(space_430X);
+            if (v_433X) {
+              arg2K0 = 1;
+              arg0K1 = 0;
+              goto L18944;}
+            else {
+              arg2K0 = 0;
+              arg0K1 = 0;
+              goto L18944;}}}
+        else {
+          goto L18817;}}
+      else {
+        v_434X = *((unsigned char *) ((((char *) (-3 + code_429X))) + 1));
+        if ((66 == v_434X)) {
+          if ((0 == (*((unsigned char *) ((((char *) (-3 + code_429X))) + (-3 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + code_429X))) + -4))))>>8)))))))) {
+            index_435X = -2 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + code_429X))) + -4))))>>8));
+            space_436X = ((((*((unsigned char *) ((((char *) (-3 + code_429X))) + index_435X))))<<8)) + (*((unsigned char *) ((((char *) (-3 + code_429X))) + (1 + index_435X))));
+            if ((space_436X < (64 + (((((SstackS) - (Sstack_limitS)))>>2))))) {
+              goto L18817;}
+            else {
+              space_437X = 1 + (((((Sstack_endS) - (SstackS)))>>2));
+              v_438X = AVAILABLEp(space_437X);
+              if (v_438X) {
+                arg2K0 = 1;
+                arg0K1 = 0;
+                goto L19000;}
+              else {
+                collect_saving_temps(1, 1, &temp1_439X);
+                v_440X = AVAILABLEp(space_437X);
+                if (v_440X) {
+                  arg2K0 = 1;
+                  arg0K1 = 0;
+                  goto L19000;}
+                else {
+                  arg2K0 = 0;
+                  arg0K1 = 0;
+                  goto L19000;}}}}
+          else {
+            goto L18862;}}
+        else {
+          goto L18862;}}}
+      break;
+    case 37 : {
+      if ((1 == (SvalS))) {
+        Scode_pointerS = ((Scode_pointerS) + (((((*((unsigned char *) ((Scode_pointerS) + 1))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + 2)))));
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}
+      else {
+        Scode_pointerS = ((Scode_pointerS) + 3);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}}
+      break;
+    case 38 : {
+      Scode_pointerS = ((Scode_pointerS) + (((((*((unsigned char *) ((Scode_pointerS) + 1))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + 2)))));
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 39 : {
+      if ((0 == (3 & (SvalS)))) {
+        p_441X = SvalS;
+        max_442X = *((unsigned char *) ((Scode_pointerS) + 1));
+        val_443X = ((p_441X)>>2);
+        if ((val_443X < 0)) {
+          goto L18718;}
+        else {
+          if ((val_443X < max_442X)) {
+            index_444X = 1 + (((val_443X)<<1));
+            arg0K0 = (((((*((unsigned char *) ((Scode_pointerS) + (1 + index_444X)))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + (2 + index_444X)))));
+            goto L18720;}
+          else {
+            goto L18718;}}}
+      else {
+        push_exception_continuationB(5, 0);
+        *((long *) (SstackS)) = (SvalS);
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 1;
+        goto L16665;}}
+      break;
+    case 40 : {
+      stack_nargs_445X = (((*((long *) ((SstackS) + 4))))>>2);
+      if ((0 == stack_nargs_445X)) {
+        arg0_446X = *((long *) ((SstackS) + 12));
+        rest_list_447X = *((long *) ((SstackS) + 8));
+        *((long *) (SstackS)) = arg0_446X;
+        SstackS = ((SstackS) + -4);
+        SvalS = (*((long *) (((char *) (-3 + rest_list_447X)))));
+        goto L19750;}
+      else {
+        arg1_448X = *((long *) ((SstackS) + (4 + (((stack_nargs_445X)<<2)))));
+        arg0_449X = *((long *) ((SstackS) + (8 + (((stack_nargs_445X)<<2)))));
+        *((long *) ((SstackS) + (8 + (((stack_nargs_445X)<<2))))) = 1;
+        *((long *) ((SstackS) + 4)) = (-4 + (((stack_nargs_445X)<<2)));
+        *((long *) (SstackS)) = arg0_449X;
+        SstackS = ((SstackS) + -4);
+        SvalS = arg1_448X;
+        goto L19750;}}
+      break;
+    case 41 : {
+      stack_nargs_450X = (((*((long *) ((SstackS) + 4))))>>2);
+      if ((stack_nargs_450X == 0)) {
+        rest_list_451X = *((long *) ((SstackS) + 8));
+        if ((25 == (*((long *) ((((char *) (-3 + rest_list_451X))) + 4))))) {
+          arg0K0 = 1;
+          goto L18616;}
+        else {
+          *((long *) ((SstackS) + 8)) = (*((long *) ((((char *) (-3 + rest_list_451X))) + 4)));
+          *((long *) ((SstackS) + 12)) = (SvalS);
+          arg0K0 = -2;
+          goto L18616;}}
+      else {
+        if ((stack_nargs_450X == 1)) {
+          if ((25 == (*((long *) ((SstackS) + 8))))) {
+            arg0K0 = 1;
+            goto L18616;}
+          else {
+            *((long *) ((SstackS) + 4)) = 0;
+            *((long *) ((SstackS) + 12)) = (SvalS);
+            arg0K0 = -2;
+            goto L18616;}}
+        else {
+          *((long *) ((SstackS) + (8 + (((stack_nargs_450X)<<2))))) = (SvalS);
+          arg0K0 = -2;
+          goto L18616;}}}
+      break;
+    case 42 : {
+      if ((1 == (SvalS))) {
+        Scode_pointerS = ((Scode_pointerS) + 1);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}
+      else {
+        x_452X = (((*((long *) ((SstackS) + 4))))>>2);
+        if ((x_452X == 0)) {
+          rest_list_453X = *((long *) ((SstackS) + 8));
+          if ((25 == (*((long *) ((((char *) (-3 + rest_list_453X))) + 4))))) {
+            arg0K0 = 1;
+            goto L19641;}
+          else {
+            *((long *) ((SstackS) + 8)) = (*((long *) ((((char *) (-3 + rest_list_453X))) + 4)));
+            *((long *) ((SstackS) + 12)) = (*((long *) (((char *) (-3 + rest_list_453X)))));
+            arg0K0 = -2;
+            goto L19641;}}
+        else {
+          if ((x_452X == 1)) {
+            if ((25 == (*((long *) ((SstackS) + 8))))) {
+              arg0K0 = 1;
+              goto L19641;}
+            else {
+              *((long *) ((SstackS) + 4)) = 0;
+              arg0K0 = -2;
+              goto L19641;}}
+          else {
+            arg0K0 = -2;
+            goto L19641;}}}}
+      break;
+    case 43 : {
+      SstackS = ((SstackS) + 4);
+      arg2_454X = *((long *) (SstackS));
+      x_455X = SvalS;
+      if ((arg2_454X == x_455X)) {
+        arg0K0 = 5;
+        goto L38026;}
+      else {
+        arg0K0 = 1;
+        goto L38026;}}
+      break;
+    case 44 : {
+      x_456X = SvalS;
+      if ((0 == (3 & x_456X))) {
+        arg0K0 = 5;
+        goto L38038;}
+      else {
+        if ((3 == (3 & x_456X))) {
+          if ((19 == (31 & ((((*((long *) ((((char *) (-3 + x_456X))) + -4))))>>2))))) {
+            arg0K0 = 5;
+            goto L38038;}
+          else {
+            goto L10622;}}
+        else {
+          goto L10622;}}}
+      break;
+    case 45 : {
+      n_457X = SvalS;
+      if ((0 == (3 & n_457X))) {
+        goto L28391;}
+      else {
+        if ((3 == (3 & n_457X))) {
+          if ((19 == (31 & ((((*((long *) ((((char *) (-3 + n_457X))) + -4))))>>2))))) {
+            goto L28391;}
+          else {
+            goto L28392;}}
+        else {
+          goto L28392;}}}
+      break;
+    case 46 : {
+      n_458X = SvalS;
+      if ((0 == (3 & n_458X))) {
+        goto L28548;}
+      else {
+        if ((3 == (3 & n_458X))) {
+          if ((19 == (31 & ((((*((long *) ((((char *) (-3 + n_458X))) + -4))))>>2))))) {
+            goto L28548;}
+          else {
+            goto L28523;}}
+        else {
+          goto L28523;}}}
+      break;
+    case 47 : {
+      n_459X = SvalS;
+      if ((0 == (3 & n_459X))) {
+        goto L28747;}
+      else {
+        if ((3 == (3 & n_459X))) {
+          if ((19 == (31 & ((((*((long *) ((((char *) (-3 + n_459X))) + -4))))>>2))))) {
+            goto L28747;}
+          else {
+            goto L28722;}}
+        else {
+          goto L28722;}}}
+      break;
+    case 48 : {
+      n_460X = SvalS;
+      if ((0 == (3 & n_460X))) {
+        goto L28946;}
+      else {
+        if ((3 == (3 & n_460X))) {
+          if ((19 == (31 & ((((*((long *) ((((char *) (-3 + n_460X))) + -4))))>>2))))) {
+            goto L28946;}
+          else {
+            goto L28921;}}
+        else {
+          goto L28921;}}}
+      break;
+    case 49 : {
+      x_461X = SvalS;
+      if ((0 == (3 & x_461X))) {
+        SvalS = 5;
+        Scode_pointerS = ((Scode_pointerS) + 1);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = x_461X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 1;
+        goto L16665;}}
+      break;
+    case 50 : {
+      x_462X = SvalS;
+      push_exception_continuationB(5, 1);
+      *((long *) (SstackS)) = x_462X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 1;
+      goto L16665;}
+      break;
+    case 51 : {
+      x_463X = SvalS;
+      push_exception_continuationB(5, 1);
+      *((long *) (SstackS)) = x_463X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 1;
+      goto L16665;}
+      break;
+    case 52 : {
+      SstackS = ((SstackS) + 4);
+      x_464X = *((long *) (SstackS));
+      y_465X = SvalS;
+      if ((0 == (3 & (x_464X | y_465X)))) {
+        z_466X = (((x_464X)>>2)) + (((y_465X)>>2));
+        if ((536870911 < z_466X)) {
+          push_exception_continuationB(5, 1);
+          *((long *) (SstackS)) = x_464X;
+          SstackS = ((SstackS) + -4);
+          *((long *) (SstackS)) = y_465X;
+          SstackS = ((SstackS) + -4);
+          arg0K0 = 2;
+          goto L16665;}
+        else {
+          if ((z_466X < -536870912)) {
+            push_exception_continuationB(5, 1);
+            *((long *) (SstackS)) = x_464X;
+            SstackS = ((SstackS) + -4);
+            *((long *) (SstackS)) = y_465X;
+            SstackS = ((SstackS) + -4);
+            arg0K0 = 2;
+            goto L16665;}
+          else {
+            SvalS = (((z_466X)<<2));
+            Scode_pointerS = ((Scode_pointerS) + 1);
+            arg1K0 = (Scode_pointerS);
+            goto L18438;}}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = x_464X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = y_465X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+      break;
+    case 53 : {
+      SstackS = ((SstackS) + 4);
+      arg2_467X = *((long *) (SstackS));
+      x_468X = SvalS;
+      if ((0 == (3 & (arg2_467X | x_468X)))) {
+        a_469X = ((arg2_467X)>>2);
+        b_470X = ((x_468X)>>2);
+        if ((a_469X < 0)) {
+          arg0K0 = (0 - a_469X);
+          goto L6775;}
+        else {
+          arg0K0 = a_469X;
+          goto L6775;}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = arg2_467X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = x_468X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+      break;
+    case 54 : {
+      SstackS = ((SstackS) + 4);
+      x_471X = *((long *) (SstackS));
+      y_472X = SvalS;
+      if ((0 == (3 & (x_471X | y_472X)))) {
+        z_473X = (((x_471X)>>2)) - (((y_472X)>>2));
+        if ((536870911 < z_473X)) {
+          push_exception_continuationB(5, 1);
+          *((long *) (SstackS)) = x_471X;
+          SstackS = ((SstackS) + -4);
+          *((long *) (SstackS)) = y_472X;
+          SstackS = ((SstackS) + -4);
+          arg0K0 = 2;
+          goto L16665;}
+        else {
+          if ((z_473X < -536870912)) {
+            push_exception_continuationB(5, 1);
+            *((long *) (SstackS)) = x_471X;
+            SstackS = ((SstackS) + -4);
+            *((long *) (SstackS)) = y_472X;
+            SstackS = ((SstackS) + -4);
+            arg0K0 = 2;
+            goto L16665;}
+          else {
+            SvalS = (((z_473X)<<2));
+            Scode_pointerS = ((Scode_pointerS) + 1);
+            arg1K0 = (Scode_pointerS);
+            goto L18438;}}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = x_471X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = y_472X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+      break;
+    case 55 : {
+      SstackS = ((SstackS) + 4);
+      arg2_474X = *((long *) (SstackS));
+      x_475X = SvalS;
+      if ((0 == (3 & (arg2_474X | x_475X)))) {
+        if ((0 == x_475X)) {
+          push_exception_continuationB(5, 1);
+          *((long *) (SstackS)) = arg2_474X;
+          SstackS = ((SstackS) + -4);
+          *((long *) (SstackS)) = x_475X;
+          SstackS = ((SstackS) + -4);
+          arg0K0 = 2;
+          goto L16665;}
+        else {
+          a_476X = ((arg2_474X)>>2);
+          b_477X = ((x_475X)>>2);
+          if ((a_476X < 0)) {
+            arg0K0 = (0 - a_476X);
+            goto L7056;}
+          else {
+            arg0K0 = a_476X;
+            goto L7056;}}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = arg2_474X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = x_475X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+      break;
+    case 56 : {
+      SstackS = ((SstackS) + 4);
+      arg2_478X = *((long *) (SstackS));
+      x_479X = SvalS;
+      if ((0 == (3 & (arg2_478X | x_479X)))) {
+        if ((arg2_478X == x_479X)) {
+          arg0K0 = 5;
+          goto L31744;}
+        else {
+          arg0K0 = 1;
+          goto L31744;}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = arg2_478X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = x_479X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+      break;
+    case 57 : {
+      SstackS = ((SstackS) + 4);
+      arg2_480X = *((long *) (SstackS));
+      x_481X = SvalS;
+      if ((0 == (3 & (arg2_480X | x_481X)))) {
+        if ((arg2_480X < x_481X)) {
+          arg0K0 = 5;
+          goto L31822;}
+        else {
+          arg0K0 = 1;
+          goto L31822;}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = arg2_480X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = x_481X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+      break;
+    case 58 : {
+      SstackS = ((SstackS) + 4);
+      arg2_482X = *((long *) (SstackS));
+      x_483X = SvalS;
+      if ((0 == (3 & (arg2_482X | x_483X)))) {
+        if ((x_483X < arg2_482X)) {
+          arg0K0 = 5;
+          goto L31900;}
+        else {
+          arg0K0 = 1;
+          goto L31900;}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = arg2_482X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = x_483X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+      break;
+    case 59 : {
+      SstackS = ((SstackS) + 4);
+      arg2_484X = *((long *) (SstackS));
+      x_485X = SvalS;
+      if ((0 == (3 & (arg2_484X | x_485X)))) {
+        if ((x_485X < arg2_484X)) {
+          arg0K0 = 1;
+          goto L31978;}
+        else {
+          arg0K0 = 5;
+          goto L31978;}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = arg2_484X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = x_485X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+      break;
+    case 60 : {
+      SstackS = ((SstackS) + 4);
+      arg2_486X = *((long *) (SstackS));
+      x_487X = SvalS;
+      if ((0 == (3 & (arg2_486X | x_487X)))) {
+        if ((arg2_486X < x_487X)) {
+          arg0K0 = 1;
+          goto L32056;}
+        else {
+          arg0K0 = 5;
+          goto L32056;}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = arg2_486X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = x_487X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+      break;
+    case 61 : {
+      SstackS = ((SstackS) + 4);
+      arg2_488X = *((long *) (SstackS));
+      x_489X = SvalS;
+      if ((0 == (3 & (arg2_488X | x_489X)))) {
+        if ((0 == x_489X)) {
+          push_exception_continuationB(5, 1);
+          *((long *) (SstackS)) = arg2_488X;
+          SstackS = ((SstackS) + -4);
+          *((long *) (SstackS)) = x_489X;
+          SstackS = ((SstackS) + -4);
+          arg0K0 = 2;
+          goto L16665;}
+        else {
+          a_490X = ((arg2_488X)>>2);
+          b_491X = ((x_489X)>>2);
+          if ((a_490X < 0)) {
+            arg0K0 = (0 - a_490X);
+            goto L7233;}
+          else {
+            arg0K0 = a_490X;
+            goto L7233;}}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = arg2_488X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = x_489X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+      break;
+    case 62 : {
+      SstackS = ((SstackS) + 4);
+      x_492X = *((long *) (SstackS));
+      y_493X = SvalS;
+      if ((0 == (3 & (x_492X | y_493X)))) {
+        if ((0 == y_493X)) {
+          push_exception_continuationB(5, 1);
+          *((long *) (SstackS)) = x_492X;
+          SstackS = ((SstackS) + -4);
+          *((long *) (SstackS)) = y_493X;
+          SstackS = ((SstackS) + -4);
+          arg0K0 = 2;
+          goto L16665;}
+        else {
+          a_494X = ((x_492X)>>2);
+          if ((a_494X < 0)) {
+            arg0K0 = (0 - a_494X);
+            goto L25338;}
+          else {
+            arg0K0 = a_494X;
+            goto L25338;}}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = x_492X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = y_493X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+      break;
+    case 63 : {
+      x_495X = SvalS;
+      if ((0 == (3 & x_495X))) {
+        SvalS = x_495X;
+        Scode_pointerS = ((Scode_pointerS) + 1);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = x_495X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 1;
+        goto L16665;}}
+      break;
+    case 64 : {
+      x_496X = SvalS;
+      if ((0 == (3 & x_496X))) {
+        SvalS = x_496X;
+        Scode_pointerS = ((Scode_pointerS) + 1);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = x_496X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 1;
+        goto L16665;}}
+      break;
+    case 65 : {
+      x_497X = SvalS;
+      if ((0 == (3 & x_497X))) {
+        SvalS = 4;
+        Scode_pointerS = ((Scode_pointerS) + 1);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = x_497X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 1;
+        goto L16665;}}
+      break;
+    case 66 : {
+      x_498X = SvalS;
+      if ((0 == (3 & x_498X))) {
+        SvalS = x_498X;
+        Scode_pointerS = ((Scode_pointerS) + 1);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = x_498X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 1;
+        goto L16665;}}
+      break;
+    case 67 : {
+      x_499X = SvalS;
+      if ((0 == (3 & x_499X))) {
+        SvalS = 0;
+        Scode_pointerS = ((Scode_pointerS) + 1);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = x_499X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 1;
+        goto L16665;}}
+      break;
+    case 68 : {
+      x_500X = SvalS;
+      push_exception_continuationB(5, 1);
+      *((long *) (SstackS)) = x_500X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 1;
+      goto L16665;}
+      break;
+    case 69 : {
+      x_501X = SvalS;
+      push_exception_continuationB(5, 1);
+      *((long *) (SstackS)) = x_501X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 1;
+      goto L16665;}
+      break;
+    case 70 : {
+      x_502X = SvalS;
+      push_exception_continuationB(5, 1);
+      *((long *) (SstackS)) = x_502X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 1;
+      goto L16665;}
+      break;
+    case 71 : {
+      x_503X = SvalS;
+      push_exception_continuationB(5, 1);
+      *((long *) (SstackS)) = x_503X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 1;
+      goto L16665;}
+      break;
+    case 72 : {
+      x_504X = SvalS;
+      push_exception_continuationB(5, 1);
+      *((long *) (SstackS)) = x_504X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 1;
+      goto L16665;}
+      break;
+    case 73 : {
+      x_505X = SvalS;
+      push_exception_continuationB(5, 1);
+      *((long *) (SstackS)) = x_505X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 1;
+      goto L16665;}
+      break;
+    case 74 : {
+      x_506X = SvalS;
+      push_exception_continuationB(5, 1);
+      *((long *) (SstackS)) = x_506X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 1;
+      goto L16665;}
+      break;
+    case 75 : {
+      x_507X = SvalS;
+      push_exception_continuationB(5, 1);
+      *((long *) (SstackS)) = x_507X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 1;
+      goto L16665;}
+      break;
+    case 76 : {
+      x_508X = SvalS;
+      if ((0 == (3 & x_508X))) {
+        if ((x_508X < 0)) {
+          goto L38295;}
+        else {
+          SvalS = 0;
+          Scode_pointerS = ((Scode_pointerS) + 1);
+          arg1K0 = (Scode_pointerS);
+          goto L18438;}}
+      else {
+        goto L38295;}}
+      break;
+    case 77 : {
+      n_509X = SvalS;
+      if ((0 == (3 & n_509X))) {
+        n_510X = ((n_509X)>>2);
+        if ((n_510X < 0)) {
+          arg0K0 = (0 - n_510X);
+          goto L25624;}
+        else {
+          arg0K0 = n_510X;
+          goto L25624;}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = n_509X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 1;
+        goto L16665;}}
+      break;
+    case 78 : {
+      SstackS = ((SstackS) + 4);
+      arg2_511X = *((long *) (SstackS));
+      x_512X = SvalS;
+      push_exception_continuationB(5, 1);
+      *((long *) (SstackS)) = arg2_511X;
+      SstackS = ((SstackS) + -4);
+      *((long *) (SstackS)) = x_512X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 2;
+      goto L16665;}
+      break;
+    case 79 : {
+      SstackS = ((SstackS) + 4);
+      arg2_513X = *((long *) (SstackS));
+      x_514X = SvalS;
+      push_exception_continuationB(5, 1);
+      *((long *) (SstackS)) = arg2_513X;
+      SstackS = ((SstackS) + -4);
+      *((long *) (SstackS)) = x_514X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 2;
+      goto L16665;}
+      break;
+    case 80 : {
+      SstackS = ((SstackS) + 4);
+      arg2_515X = *((long *) (SstackS));
+      x_516X = SvalS;
+      push_exception_continuationB(5, 1);
+      *((long *) (SstackS)) = arg2_515X;
+      SstackS = ((SstackS) + -4);
+      *((long *) (SstackS)) = x_516X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 2;
+      goto L16665;}
+      break;
+    case 81 : {
+      x_517X = SvalS;
+      if ((0 == (3 & x_517X))) {
+        SvalS = (~ (3 | x_517X));
+        Scode_pointerS = ((Scode_pointerS) + 1);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = x_517X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 1;
+        goto L16665;}}
+      break;
+    case 82 : {
+      SstackS = ((SstackS) + 4);
+      arg2_518X = *((long *) (SstackS));
+      x_519X = SvalS;
+      if ((0 == (3 & (arg2_518X | x_519X)))) {
+        SvalS = (arg2_518X & x_519X);
+        Scode_pointerS = ((Scode_pointerS) + 1);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = arg2_518X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = x_519X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+      break;
+    case 83 : {
+      SstackS = ((SstackS) + 4);
+      arg2_520X = *((long *) (SstackS));
+      x_521X = SvalS;
+      if ((0 == (3 & (arg2_520X | x_521X)))) {
+        SvalS = (arg2_520X | x_521X);
+        Scode_pointerS = ((Scode_pointerS) + 1);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = arg2_520X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = x_521X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+      break;
+    case 84 : {
+      SstackS = ((SstackS) + 4);
+      arg2_522X = *((long *) (SstackS));
+      x_523X = SvalS;
+      if ((0 == (3 & (arg2_522X | x_523X)))) {
+        SvalS = (arg2_522X ^ x_523X);
+        Scode_pointerS = ((Scode_pointerS) + 1);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = arg2_522X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = x_523X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+      break;
+    case 85 : {
+      SstackS = ((SstackS) + 4);
+      x_524X = *((long *) (SstackS));
+      y_525X = SvalS;
+      if ((0 == (3 & (x_524X | y_525X)))) {
+        value_526X = ((x_524X)>>2);
+        count_527X = ((y_525X)>>2);
+        if ((count_527X < 0)) {
+          PS_SHIFT_RIGHT(value_526X, (0 - count_527X), x_528X)
+          SvalS = (((x_528X)<<2));
+          Scode_pointerS = ((Scode_pointerS) + 1);
+          arg1K0 = (Scode_pointerS);
+          goto L18438;}
+        else {
+          PS_SHIFT_LEFT(value_526X, count_527X, x_529X)
+          result_530X = (((((x_529X)<<2)))>>2);
+          PS_SHIFT_RIGHT(result_530X, count_527X, x_531X)
+          if ((value_526X == x_531X)) {
+            if ((value_526X < 0)) {
+              if ((result_530X < 0)) {
+                goto L25903;}
+              else {
+                push_exception_continuationB(5, 1);
+                *((long *) (SstackS)) = x_524X;
+                SstackS = ((SstackS) + -4);
+                *((long *) (SstackS)) = y_525X;
+                SstackS = ((SstackS) + -4);
+                arg0K0 = 2;
+                goto L16665;}}
+            else {
+              if ((result_530X < 0)) {
+                push_exception_continuationB(5, 1);
+                *((long *) (SstackS)) = x_524X;
+                SstackS = ((SstackS) + -4);
+                *((long *) (SstackS)) = y_525X;
+                SstackS = ((SstackS) + -4);
+                arg0K0 = 2;
+                goto L16665;}
+              else {
+                goto L25903;}}}
+          else {
+            push_exception_continuationB(5, 1);
+            *((long *) (SstackS)) = x_524X;
+            SstackS = ((SstackS) + -4);
+            *((long *) (SstackS)) = y_525X;
+            SstackS = ((SstackS) + -4);
+            arg0K0 = 2;
+            goto L16665;}}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = x_524X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = y_525X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+      break;
+    case 86 : {
+      x_532X = SvalS;
+      if ((9 == (255 & x_532X))) {
+        arg0K0 = 5;
+        goto L38383;}
+      else {
+        arg0K0 = 1;
+        goto L38383;}}
+      break;
+    case 87 : {
+      SstackS = ((SstackS) + 4);
+      arg2_533X = *((long *) (SstackS));
+      if ((9 == (255 & arg2_533X))) {
+        if ((9 == (255 & (SvalS)))) {
+          x_534X = SvalS;
+          if ((arg2_533X == x_534X)) {
+            arg0K0 = 5;
+            goto L28166;}
+          else {
+            arg0K0 = 1;
+            goto L28166;}}
+        else {
+          goto L28139;}}
+      else {
+        goto L28139;}}
+      break;
+    case 88 : {
+      SstackS = ((SstackS) + 4);
+      arg2_535X = *((long *) (SstackS));
+      if ((9 == (255 & arg2_535X))) {
+        if ((9 == (255 & (SvalS)))) {
+          x_536X = SvalS;
+          if ((arg2_535X < x_536X)) {
+            arg0K0 = 5;
+            goto L28076;}
+          else {
+            arg0K0 = 1;
+            goto L28076;}}
+        else {
+          goto L28049;}}
+      else {
+        goto L28049;}}
+      break;
+    case 89 : {
+      if ((9 == (255 & (SvalS)))) {
+        SvalS = (((((((((SvalS))>>8)))))<<2));
+        Scode_pointerS = ((Scode_pointerS) + 1);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = (SvalS);
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 1;
+        goto L16665;}}
+      break;
+    case 90 : {
+      if ((0 == (3 & (SvalS)))) {
+        x_537X = (((SvalS))>>2);
+        if ((255 < x_537X)) {
+          goto L32748;}
+        else {
+          if ((x_537X < 0)) {
+            goto L32748;}
+          else {
+            SvalS = (9 + (((((x_537X)))<<8)));
+            Scode_pointerS = ((Scode_pointerS) + 1);
+            arg1K0 = (Scode_pointerS);
+            goto L18438;}}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = (SvalS);
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 1;
+        goto L16665;}}
+      break;
+    case 91 : {
+      x_538X = SvalS;
+      if ((21 == x_538X)) {
+        arg0K0 = 5;
+        goto L38412;}
+      else {
+        arg0K0 = 1;
+        goto L38412;}}
+      break;
+    case 92 : {
+      x_539X = SvalS;
+      type_540X = *((unsigned char *) ((Scode_pointerS) + 1));
+      if ((3 == (3 & x_539X))) {
+        if (((31 & ((((*((long *) ((((char *) (-3 + x_539X))) + -4))))>>2))) == type_540X)) {
+          arg0K0 = 5;
+          goto L38426;}
+        else {
+          arg0K0 = 1;
+          goto L38426;}}
+      else {
+        arg0K0 = 1;
+        goto L38426;}}
+      break;
+    case 93 : {
+      stob_541X = SvalS;
+      type_542X = *((unsigned char *) ((Scode_pointerS) + 1));
+      if ((3 == (3 & stob_541X))) {
+        if (((31 & ((((*((long *) ((((char *) (-3 + stob_541X))) + -4))))>>2))) == type_542X)) {
+          SvalS = (-4 & (3 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + stob_541X))) + -4))))>>8))));
+          Scode_pointerS = ((Scode_pointerS) + 2);
+          arg1K0 = (Scode_pointerS);
+          goto L18438;}
+        else {
+          goto L21229;}}
+      else {
+        goto L21229;}}
+      break;
+    case 94 : {
+      len_543X = *((unsigned char *) ((Scode_pointerS) + 1));
+      space_544X = 4 + (((len_543X)<<2));
+      v_545X = AVAILABLEp(space_544X);
+      if (v_545X) {
+        goto L21301;}
+      else {
+        collect_saving_temps(1, 1, &temp1_546X);
+        v_547X = AVAILABLEp(space_544X);
+        if (v_547X) {
+          goto L21301;}
+        else {
+          ps_error("Scheme48 heap overflow", 0);
+          goto L21301;}}}
+      break;
+    case 95 : {
+      SstackS = ((SstackS) + 4);
+      len_548X = (((*((long *) (SstackS))))>>2);
+      space_549X = 4 + (((len_548X)<<2));
+      v_550X = AVAILABLEp(space_549X);
+      if (v_550X) {
+        goto L21483;}
+      else {
+        collect_saving_temps(1, 1, &temp1_551X);
+        v_552X = AVAILABLEp(space_549X);
+        if (v_552X) {
+          goto L21483;}
+        else {
+          ps_error("Scheme48 heap overflow", 0);
+          goto L21483;}}}
+      break;
+    case 96 : {
+      stob_553X = SvalS;
+      offset_554X = *((unsigned char *) ((Scode_pointerS) + 2));
+      type_555X = *((unsigned char *) ((Scode_pointerS) + 1));
+      if ((3 == (3 & stob_553X))) {
+        if (((31 & ((((*((long *) ((((char *) (-3 + stob_553X))) + -4))))>>2))) == type_555X)) {
+          SvalS = (*((long *) ((((char *) (-3 + stob_553X))) + (((offset_554X)<<2)))));
+          Scode_pointerS = ((Scode_pointerS) + 3);
+          arg1K0 = (Scode_pointerS);
+          goto L18438;}
+        else {
+          goto L21693;}}
+      else {
+        goto L21693;}}
+      break;
+    case 97 : {
+      SstackS = ((SstackS) + 4);
+      stob_556X = *((long *) (SstackS));
+      value_557X = SvalS;
+      offset_558X = *((unsigned char *) ((Scode_pointerS) + 2));
+      type_559X = *((unsigned char *) ((Scode_pointerS) + 1));
+      if ((3 == (3 & stob_556X))) {
+        if (((31 & ((((*((long *) ((((char *) (-3 + stob_556X))) + -4))))>>2))) == type_559X)) {
+          if ((3 == (3 & stob_556X))) {
+            if ((0 == (128 & (*((long *) ((((char *) (-3 + stob_556X))) + -4)))))) {
+              addr_560X = (((char *) (-3 + stob_556X))) + (((offset_558X)<<2));
+              S48_WRITE_BARRIER(stob_556X, addr_560X, value_557X);
+              *((long *) addr_560X) = value_557X;
+              SvalS = 13;
+              Scode_pointerS = ((Scode_pointerS) + 3);
+              arg1K0 = (Scode_pointerS);
+              goto L18438;}
+            else {
+              goto L21796;}}
+          else {
+            goto L21796;}}
+        else {
+          goto L21796;}}
+      else {
+        goto L21796;}}
+      break;
+    case 98 : {
+      SstackS = ((SstackS) + 4);
+      len_561X = *((long *) (SstackS));
+      init_562X = SvalS;
+      type_563X = *((unsigned char *) ((Scode_pointerS) + 1));
+      if ((0 == (3 & len_561X))) {
+        len_564X = ((len_561X)>>2);
+        size_565X = 1 + len_564X;
+        if ((len_564X < 0)) {
+          goto L21981;}
+        else {
+          if ((4194305 < size_565X)) {
+            goto L21981;}
+          else {
+            v_566X = AVAILABLEp(size_565X);
+            if (v_566X) {
+              arg2K0 = 1;
+              arg0K1 = init_562X;
+              goto L21999;}
+            else {
+              temp0_567X = collect_saving_temps(init_562X, 1, &temp1_568X);
+              v_569X = AVAILABLEp(size_565X);
+              if (v_569X) {
+                arg2K0 = 1;
+                arg0K1 = temp0_567X;
+                goto L21999;}
+              else {
+                arg2K0 = 0;
+                arg0K1 = temp0_567X;
+                goto L21999;}}}}}
+      else {
+        push_exception_continuationB(5, 2);
+        *((long *) (SstackS)) = (((type_563X)<<2));
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = len_561X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = init_562X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 3;
+        goto L16665;}}
+      break;
+    case 99 : {
+      SstackS = ((SstackS) + 4);
+      stob_570X = *((long *) (SstackS));
+      index_571X = SvalS;
+      type_572X = *((unsigned char *) ((Scode_pointerS) + 1));
+      if ((0 == (3 & index_571X))) {
+        if ((3 == (3 & stob_570X))) {
+          if (((31 & ((((*((long *) ((((char *) (-3 + stob_570X))) + -4))))>>2))) == type_572X)) {
+            len_573X = (((3 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + stob_570X))) + -4))))>>8))))>>2);
+            index_574X = ((index_571X)>>2);
+            if ((index_574X < 0)) {
+              goto L22277;}
+            else {
+              if ((index_574X < len_573X)) {
+                SvalS = (*((long *) ((((char *) (-3 + stob_570X))) + (-4 & index_571X))));
+                Scode_pointerS = ((Scode_pointerS) + 2);
+                arg1K0 = (Scode_pointerS);
+                goto L18438;}
+              else {
+                goto L22277;}}}
+          else {
+            goto L22254;}}
+        else {
+          goto L22254;}}
+      else {
+        goto L22254;}}
+      break;
+    case 100 : {
+      SstackS = ((SstackS) + 4);
+      arg2_575X = *((long *) (SstackS));
+      SstackS = ((SstackS) + 4);
+      stob_576X = *((long *) (SstackS));
+      value_577X = SvalS;
+      type_578X = *((unsigned char *) ((Scode_pointerS) + 1));
+      if ((0 == (3 & arg2_575X))) {
+        if ((3 == (3 & stob_576X))) {
+          if (((31 & ((((*((long *) ((((char *) (-3 + stob_576X))) + -4))))>>2))) == type_578X)) {
+            if ((3 == (3 & stob_576X))) {
+              if ((0 == (128 & (*((long *) ((((char *) (-3 + stob_576X))) + -4)))))) {
+                len_579X = (((3 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + stob_576X))) + -4))))>>8))))>>2);
+                index_580X = ((arg2_575X)>>2);
+                if ((index_580X < 0)) {
+                  goto L22517;}
+                else {
+                  if ((index_580X < len_579X)) {
+                    addr_581X = (((char *) (-3 + stob_576X))) + (-4 & arg2_575X);
+                    S48_WRITE_BARRIER(stob_576X, addr_581X, value_577X);
+                    *((long *) addr_581X) = value_577X;
+                    SvalS = 13;
+                    Scode_pointerS = ((Scode_pointerS) + 2);
+                    arg1K0 = (Scode_pointerS);
+                    goto L18438;}
+                  else {
+                    goto L22517;}}}
+              else {
+                goto L22492;}}
+            else {
+              goto L22492;}}
+          else {
+            goto L22492;}}
+        else {
+          goto L22492;}}
+      else {
+        goto L22492;}}
+      break;
+    case 101 : {
+      SstackS = ((SstackS) + 4);
+      arg2_582X = *((long *) (SstackS));
+      if ((0 == (3 & (arg2_582X | (SvalS))))) {
+        len_583X = ((arg2_582X)>>2);
+        init_584X = (((SvalS))>>2);
+        size_585X = 1 + ((((3 + len_583X))>>2));
+        if ((len_583X < 0)) {
+          goto L26074;}
+        else {
+          if ((4194305 < size_585X)) {
+            goto L26074;}
+          else {
+            v_586X = AVAILABLEp(size_585X);
+            if (v_586X) {
+              goto L26166;}
+            else {
+              collect_saving_temps(1, 1, &temp1_587X);
+              v_588X = AVAILABLEp(size_585X);
+              if (v_588X) {
+                goto L26166;}
+              else {
+                push_exception_continuationB(8, 1);
+                *((long *) (SstackS)) = (((len_583X)<<2));
+                SstackS = ((SstackS) + -4);
+                *((long *) (SstackS)) = (((init_584X)<<2));
+                SstackS = ((SstackS) + -4);
+                arg0K0 = 2;
+                goto L16665;}}}}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = arg2_582X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = (SvalS);
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+      break;
+    case 102 : {
+      obj_589X = SvalS;
+      if ((3 == (3 & obj_589X))) {
+        if ((17 == (31 & ((((*((long *) ((((char *) (-3 + obj_589X))) + -4))))>>2))))) {
+          SvalS = (((((long)(((unsigned long)(*((long *) ((((char *) (-3 + (SvalS)))) + -4))))>>8)))<<2));
+          Scode_pointerS = ((Scode_pointerS) + 1);
+          arg1K0 = (Scode_pointerS);
+          goto L18438;}
+        else {
+          goto L36239;}}
+      else {
+        goto L36239;}}
+      break;
+    case 103 : {
+      SstackS = ((SstackS) + 4);
+      arg2_590X = *((long *) (SstackS));
+      if ((3 == (3 & arg2_590X))) {
+        if ((17 == (31 & ((((*((long *) ((((char *) (-3 + arg2_590X))) + -4))))>>2))))) {
+          if ((0 == (3 & (SvalS)))) {
+            index_591X = (((SvalS))>>2);
+            len_592X = (long)(((unsigned long)(*((long *) ((((char *) (-3 + arg2_590X))) + -4))))>>8);
+            if ((index_591X < 0)) {
+              goto L32854;}
+            else {
+              if ((index_591X < len_592X)) {
+                SvalS = ((((*((unsigned char *) ((((char *) (-3 + arg2_590X))) + index_591X))))<<2));
+                Scode_pointerS = ((Scode_pointerS) + 1);
+                arg1K0 = (Scode_pointerS);
+                goto L18438;}
+              else {
+                goto L32854;}}}
+          else {
+            goto L35818;}}
+        else {
+          goto L35818;}}
+      else {
+        goto L35818;}}
+      break;
+    case 104 : {
+      SstackS = ((SstackS) + 4);
+      arg2_593X = *((long *) (SstackS));
+      SstackS = ((SstackS) + 4);
+      arg3_594X = *((long *) (SstackS));
+      if ((3 == (3 & arg3_594X))) {
+        if ((17 == (31 & ((((*((long *) ((((char *) (-3 + arg3_594X))) + -4))))>>2))))) {
+          if ((0 == (3 & (arg2_593X | (SvalS))))) {
+            index_595X = ((arg2_593X)>>2);
+            Kchar_596X = (((SvalS))>>2);
+            if ((3 == (3 & arg3_594X))) {
+              if ((0 == (128 & (*((long *) ((((char *) (-3 + arg3_594X))) + -4)))))) {
+                len_597X = (long)(((unsigned long)(*((long *) ((((char *) (-3 + arg3_594X))) + -4))))>>8);
+                if ((index_595X < 0)) {
+                  goto L29802;}
+                else {
+                  if ((index_595X < len_597X)) {
+                    *((unsigned char *) ((((char *) (-3 + arg3_594X))) + index_595X)) = Kchar_596X;
+                    SvalS = 13;
+                    Scode_pointerS = ((Scode_pointerS) + 1);
+                    arg1K0 = (Scode_pointerS);
+                    goto L18438;}
+                  else {
+                    goto L29802;}}}
+              else {
+                goto L29781;}}
+            else {
+              goto L29781;}}
+          else {
+            goto L34230;}}
+        else {
+          goto L34230;}}
+      else {
+        goto L34230;}}
+      break;
+    case 105 : {
+      SstackS = ((SstackS) + 4);
+      arg2_598X = *((long *) (SstackS));
+      if ((0 == (3 & arg2_598X))) {
+        if ((9 == (255 & (SvalS)))) {
+          len_599X = ((arg2_598X)>>2);
+          init_600X = ((((SvalS))>>8));
+          size_601X = 1 + ((((4 + len_599X))>>2));
+          if ((len_599X < 0)) {
+            goto L26308;}
+          else {
+            if ((4194305 < size_601X)) {
+              goto L26308;}
+            else {
+              v_602X = AVAILABLEp(size_601X);
+              if (v_602X) {
+                goto L26400;}
+              else {
+                collect_saving_temps(1, 1, &temp1_603X);
+                v_604X = AVAILABLEp(size_601X);
+                if (v_604X) {
+                  goto L26400;}
+                else {
+                  push_exception_continuationB(8, 1);
+                  *((long *) (SstackS)) = (((len_599X)<<2));
+                  SstackS = ((SstackS) + -4);
+                  *((long *) (SstackS)) = (9 + ((((init_600X))<<8)));
+                  SstackS = ((SstackS) + -4);
+                  arg0K0 = 2;
+                  goto L16665;}}}}}
+        else {
+          goto L32935;}}
+      else {
+        goto L32935;}}
+      break;
+    case 106 : {
+      obj_605X = SvalS;
+      if ((3 == (3 & obj_605X))) {
+        if ((16 == (31 & ((((*((long *) ((((char *) (-3 + obj_605X))) + -4))))>>2))))) {
+          SvalS = (-4 + (((((long)(((unsigned long)(*((long *) ((((char *) (-3 + (SvalS)))) + -4))))>>8)))<<2)));
+          Scode_pointerS = ((Scode_pointerS) + 1);
+          arg1K0 = (Scode_pointerS);
+          goto L18438;}
+        else {
+          goto L36289;}}
+      else {
+        goto L36289;}}
+      break;
+    case 107 : {
+      SstackS = ((SstackS) + 4);
+      arg2_606X = *((long *) (SstackS));
+      if ((3 == (3 & arg2_606X))) {
+        if ((16 == (31 & ((((*((long *) ((((char *) (-3 + arg2_606X))) + -4))))>>2))))) {
+          if ((0 == (3 & (SvalS)))) {
+            index_607X = (((SvalS))>>2);
+            len_608X = -1 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + arg2_606X))) + -4))))>>8));
+            if ((index_607X < 0)) {
+              goto L32998;}
+            else {
+              if ((index_607X < len_608X)) {
+                SvalS = (9 + ((((((*((unsigned char *) ((((char *) (-3 + arg2_606X))) + index_607X))))))<<8)));
+                Scode_pointerS = ((Scode_pointerS) + 1);
+                arg1K0 = (Scode_pointerS);
+                goto L18438;}
+              else {
+                goto L32998;}}}
+          else {
+            goto L35914;}}
+        else {
+          goto L35914;}}
+      else {
+        goto L35914;}}
+      break;
+    case 108 : {
+      SstackS = ((SstackS) + 4);
+      arg2_609X = *((long *) (SstackS));
+      SstackS = ((SstackS) + 4);
+      arg3_610X = *((long *) (SstackS));
+      if ((3 == (3 & arg3_610X))) {
+        if ((16 == (31 & ((((*((long *) ((((char *) (-3 + arg3_610X))) + -4))))>>2))))) {
+          if ((0 == (3 & arg2_609X))) {
+            if ((9 == (255 & (SvalS)))) {
+              index_611X = ((arg2_609X)>>2);
+              Kchar_612X = ((((SvalS))>>8));
+              if ((3 == (3 & arg3_610X))) {
+                if ((0 == (128 & (*((long *) ((((char *) (-3 + arg3_610X))) + -4)))))) {
+                  len_613X = -1 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + arg3_610X))) + -4))))>>8));
+                  if ((index_611X < 0)) {
+                    goto L29957;}
+                  else {
+                    if ((index_611X < len_613X)) {
+                      *((unsigned char *) ((((char *) (-3 + arg3_610X))) + index_611X)) = (Kchar_612X);
+                      SvalS = 13;
+                      Scode_pointerS = ((Scode_pointerS) + 1);
+                      arg1K0 = (Scode_pointerS);
+                      goto L18438;}
+                    else {
+                      goto L29957;}}}
+                else {
+                  goto L29936;}}
+              else {
+                goto L29936;}}
+            else {
+              goto L34356;}}
+          else {
+            goto L34356;}}
+        else {
+          goto L34356;}}
+      else {
+        goto L34356;}}
+      break;
+    case 109 : {
+      v_614X = AVAILABLEp(3);
+      if (v_614X) {
+        goto L24478;}
+      else {
+        collect_saving_temps(1, 1, &temp1_615X);
+        v_616X = AVAILABLEp(3);
+        if (v_616X) {
+          goto L24478;}
+        else {
+          ps_error("Scheme48 heap overflow", 0);
+          goto L24478;}}}
+      break;
+    case 110 : {
+      obj_617X = SvalS;
+      if ((3 == (3 & obj_617X))) {
+        if ((4 == (31 & ((((*((long *) ((((char *) (-3 + obj_617X))) + -4))))>>2))))) {
+          x_618X = SvalS;
+          descriptor_619X = *((long *) ((((char *) (-3 + x_618X))) + 4));
+          if ((17 == (255 & descriptor_619X))) {
+            if ((529 == (*((long *) ((((char *) (-3 + x_618X))) + 4))))) {
+              arg0K0 = 5;
+              goto L33976;}
+            else {
+              arg0K0 = 1;
+              goto L33976;}}
+          else {
+            arg0K0 = 5;
+            goto L33976;}}
+        else {
+          goto L33957;}}
+      else {
+        goto L33957;}}
+      break;
+    case 111 : {
+      SstackS = ((SstackS) + 4);
+      arg2_620X = *((long *) (SstackS));
+      if ((3 == (3 & arg2_620X))) {
+        if ((4 == (31 & ((((*((long *) ((((char *) (-3 + arg2_620X))) + -4))))>>2))))) {
+          x_621X = SvalS;
+          if ((1 == x_621X)) {
+            goto L29544;}
+          else {
+            if ((5 == x_621X)) {
+              goto L29544;}
+            else {
+              goto L29551;}}}
+        else {
+          goto L29551;}}
+      else {
+        goto L29551;}}
+      break;
+    case 112 : {
+      x_622X = SvalS;
+      if ((3 == (3 & x_622X))) {
+        if ((0 == (128 & (*((long *) ((((char *) (-3 + x_622X))) + -4)))))) {
+          arg0K0 = 1;
+          goto L38498;}
+        else {
+          arg0K0 = 5;
+          goto L38498;}}
+      else {
+        arg0K0 = 5;
+        goto L38498;}}
+      break;
+    case 113 : {
+      x_623X = SvalS;
+      if ((3 == (3 & x_623X))) {
+        if ((0 == (128 & (*((long *) ((((char *) (-3 + x_623X))) + -4)))))) {
+          *((long *) ((((char *) (-3 + x_623X))) + -4)) = (128 | (*((long *) ((((char *) (-3 + x_623X))) + -4))));
+          goto L33080;}
+        else {
+          goto L33080;}}
+      else {
+        goto L33080;}}
+      break;
+    case 114 : {
+      v_624X = AVAILABLEp(72);
+      if (v_624X) {
+        arg2K0 = 1;
+        arg0K1 = 0;
+        goto L33131;}
+      else {
+        collect_saving_temps(1, 1, &temp1_625X);
+        v_626X = AVAILABLEp(72);
+        if (v_626X) {
+          arg2K0 = 1;
+          arg0K1 = 0;
+          goto L33131;}
+        else {
+          arg2K0 = 0;
+          arg0K1 = 0;
+          goto L33131;}}}
+      break;
+    case 115 : {
+      v_627X = AVAILABLEp(66);
+      if (v_627X) {
+        arg2K0 = 1;
+        arg0K1 = 0;
+        goto L34474;}
+      else {
+        collect_saving_temps(1, 1, &temp1_628X);
+        v_629X = AVAILABLEp(66);
+        if (v_629X) {
+          arg2K0 = 1;
+          arg0K1 = 0;
+          goto L34474;}
+        else {
+          arg2K0 = 0;
+          arg0K1 = 0;
+          goto L34474;}}}
+      break;
+    case 116 : {
+      v_630X = AVAILABLEp(66);
+      if (v_630X) {
+        arg2K0 = 1;
+        arg0K1 = 0;
+        goto L37343;}
+      else {
+        collect_saving_temps(1, 1, &temp1_631X);
+        v_632X = AVAILABLEp(66);
+        if (v_632X) {
+          arg2K0 = 1;
+          arg0K1 = 0;
+          goto L37343;}
+        else {
+          arg2K0 = 0;
+          arg0K1 = 0;
+          goto L37343;}}}
+      break;
+    case 117 : {
+      v_633X = AVAILABLEp(66);
+      if (v_633X) {
+        arg2K0 = 1;
+        arg0K1 = 0;
+        goto L37603;}
+      else {
+        collect_saving_temps(1, 1, &temp1_634X);
+        v_635X = AVAILABLEp(66);
+        if (v_635X) {
+          arg2K0 = 1;
+          arg0K1 = 0;
+          goto L37603;}
+        else {
+          arg2K0 = 0;
+          arg0K1 = 0;
+          goto L37603;}}}
+      break;
+    case 118 : {
+      obj_636X = SvalS;
+      if ((3 == (3 & obj_636X))) {
+        if ((5 == (31 & ((((*((long *) ((((char *) (-3 + obj_636X))) + -4))))>>2))))) {
+          channel_637X = SvalS;
+          head_638X = Spending_channels_headS;
+          if ((1 == head_638X)) {
+            addr_639X = (((char *) (-3 + channel_637X))) + 16;
+            S48_WRITE_BARRIER(channel_637X, addr_639X, 1);
+            *((long *) addr_639X) = 1;
+            n_640X = ps_abort_fd_op(((((*((long *) ((((char *) (-3 + channel_637X))) + 8))))>>2)));
+            arg0K0 = (((n_640X)<<2));
+            goto L33202;}
+          else {
+            if ((channel_637X == head_638X)) {
+              channel_641X = Spending_channels_headS;
+              next_642X = *((long *) ((((char *) (-3 + channel_641X))) + 12));
+              Spending_channels_headS = next_642X;
+              addr_643X = (((char *) (-3 + channel_641X))) + 12;
+              S48_WRITE_BARRIER(channel_641X, addr_643X, 1);
+              *((long *) addr_643X) = 1;
+              if ((1 == next_642X)) {
+                Spending_channels_tailS = 1;
+                goto L8173;}
+              else {
+                goto L8173;}}
+            else {
+              arg0K0 = (*((long *) ((((char *) (-3 + head_638X))) + 12)));
+              arg0K1 = head_638X;
+              goto L8179;}}}
+        else {
+          goto L33185;}}
+      else {
+        goto L33185;}}
+      break;
+    case 119 : {
+      space_644X = 3 * (Snumber_of_channelsS);
+      v_645X = AVAILABLEp(space_644X);
+      if (v_645X) {
+        goto L14777;}
+      else {
+        collect_saving_temps(1, 1, &temp1_646X);
+        v_647X = AVAILABLEp(space_644X);
+        if (v_647X) {
+          goto L14777;}
+        else {
+          ps_error("Scheme48 heap overflow", 0);
+          goto L14777;}}}
+      break;
+    case 120 : {
+      SvalS = 529;
+      Scode_pointerS = ((Scode_pointerS) + 1);
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 121 : {
+      SvalS = 13;
+      Scode_pointerS = ((Scode_pointerS) + 1);
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 122 : {
+      x_648X = SvalS;
+      push_exception_continuationB(16, 1);
+      *((long *) (SstackS)) = x_648X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 1;
+      goto L16665;}
+      break;
+    case 123 : {
+      SvalS = 1;
+      Scode_pointerS = ((Scode_pointerS) + 1);
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 124 : {
+      SvalS = 21;
+      Scode_pointerS = ((Scode_pointerS) + 1);
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 125 : {
+      v_649X = AVAILABLEp(66);
+      if (v_649X) {
+        arg2K0 = 1;
+        arg0K1 = 0;
+        goto L34575;}
+      else {
+        collect_saving_temps(1, 1, &temp1_650X);
+        v_651X = AVAILABLEp(66);
+        if (v_651X) {
+          arg2K0 = 1;
+          arg0K1 = 0;
+          goto L34575;}
+        else {
+          arg2K0 = 0;
+          arg0K1 = 0;
+          goto L34575;}}}
+      break;
+    case 126 : {
+      SvalS = 13;
+      collect_saving_temps(0, 0, &v_652X);
+      Scode_pointerS = ((Scode_pointerS) + 1);
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 127 : {
+      obj_653X = SvalS;
+      if ((3 == (3 & obj_653X))) {
+        if ((16 == (31 & ((((*((long *) ((((char *) (-3 + obj_653X))) + -4))))>>2))))) {
+          x_654X = SvalS;
+          n_655X = -1 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + x_654X))) + -4))))>>8));
+          arg0K0 = 0;
+          arg0K1 = 0;
+          goto L35407;}
+        else {
+          goto L35384;}}
+      else {
+        goto L35384;}}
+      break;
+    case 128 : {
+      v_656X = AVAILABLEp(6);
+      if (v_656X) {
+        goto L38564;}
+      else {
+        collect_saving_temps(1, 1, &temp1_657X);
+        v_658X = AVAILABLEp(6);
+        if (v_658X) {
+          goto L38564;}
+        else {
+          ps_error("Scheme48 heap overflow", 0);
+          goto L38564;}}}
+      break;
+    case 129 : {
+      SstackS = ((SstackS) + 4);
+      arg2_659X = *((long *) (SstackS));
+      if ((0 == (3 & arg2_659X))) {
+        key_660X = ((arg2_659X)>>2);
+        other_661X = SvalS;
+        if ((5 == key_660X)) {
+          SvalS = (-4 & other_661X);
+          Scode_pointerS = ((Scode_pointerS) + 1);
+          arg1K0 = (Scode_pointerS);
+          goto L18438;}
+        else {
+          if ((0 == key_660X)) {
+            x_662X = s48_available();
+            SvalS = (((x_662X)<<2));
+            Scode_pointerS = ((Scode_pointerS) + 1);
+            arg1K0 = (Scode_pointerS);
+            goto L18438;}
+          else {
+            if ((1 == key_660X)) {
+              bytes_663X = s48_heap_size();
+              SvalS = (-4 & (3 + bytes_663X));
+              Scode_pointerS = ((Scode_pointerS) + 1);
+              arg1K0 = (Scode_pointerS);
+              goto L18438;}
+            else {
+              if ((2 == key_660X)) {
+                SvalS = (((((Sstack_endS) - (Sstack_beginS)))<<2));
+                Scode_pointerS = ((Scode_pointerS) + 1);
+                arg1K0 = (Scode_pointerS);
+                goto L18438;}
+              else {
+                if ((3 == key_660X)) {
+                  x_664X = s48_gc_count();
+                  SvalS = (((x_664X)<<2));
+                  Scode_pointerS = ((Scode_pointerS) + 1);
+                  arg1K0 = (Scode_pointerS);
+                  goto L18438;}
+                else {
+                  if ((4 == key_660X)) {
+                    push_exception_continuationB(15, 1);
+                    *((long *) (SstackS)) = (((key_660X)<<2));
+                    SstackS = ((SstackS) + -4);
+                    *((long *) (SstackS)) = other_661X;
+                    SstackS = ((SstackS) + -4);
+                    arg0K0 = 2;
+                    goto L16665;}
+                  else {
+                    push_exception_continuationB(18, 1);
+                    *((long *) (SstackS)) = (((key_660X)<<2));
+                    SstackS = ((SstackS) + -4);
+                    *((long *) (SstackS)) = other_661X;
+                    SstackS = ((SstackS) + -4);
+                    arg0K0 = 2;
+                    goto L16665;}}}}}}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = arg2_659X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = (SvalS);
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+      break;
+    case 130 : {
+      if ((0 == (3 & (SvalS)))) {
+        type_665X = (((SvalS))>>2);
+        arg2K0 = 1;
+        goto L33293;}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = (SvalS);
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 1;
+        goto L16665;}}
+      break;
+    case 131 : {
+      x_666X = SvalS;
+      arg2K0 = 1;
+      arg0K1 = x_666X;
+      goto L38614;}
+      break;
+    case 132 : {
+      SvalS = (Scurrent_threadS);
+      Scode_pointerS = ((Scode_pointerS) + 1);
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 133 : {
+      Scurrent_threadS = (SvalS);
+      SvalS = 13;
+      Scode_pointerS = ((Scode_pointerS) + 1);
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 134 : {
+      SvalS = (Ssession_dataS);
+      Scode_pointerS = ((Scode_pointerS) + 1);
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 135 : {
+      Ssession_dataS = (SvalS);
+      SvalS = 13;
+      Scode_pointerS = ((Scode_pointerS) + 1);
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 136 : {
+      obj_667X = SvalS;
+      if ((3 == (3 & obj_667X))) {
+        if ((2 == (31 & ((((*((long *) ((((char *) (-3 + obj_667X))) + -4))))>>2))))) {
+          if ((((((3 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + (SvalS)))) + -4))))>>8))))>>2)) < 160)) {
+            goto L20570;}
+          else {
+            temp_668X = Sexception_handlersS;
+            Sexception_handlersS = (SvalS);
+            SvalS = temp_668X;
+            Scode_pointerS = ((Scode_pointerS) + 1);
+            arg1K0 = (Scode_pointerS);
+            goto L18438;}}
+        else {
+          goto L20570;}}
+      else {
+        goto L20570;}}
+      break;
+    case 137 : {
+      SstackS = ((SstackS) + 4);
+      p_669X = *((long *) (SstackS));
+      SstackS = ((SstackS) + 4);
+      template_670X = *((long *) (SstackS));
+      SstackS = ((SstackS) + 4);
+      SstackS = ((SstackS) + 4);
+      p_671X = *((long *) (SstackS));
+      StemplateS = template_670X;
+      Scode_pointerS = ((((char *) (-3 + (*((long *) (((char *) (-3 + template_670X)))))))) + ((((((((((p_669X)>>2)) + (((p_671X)>>2))))<<2)))>>2)));
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}
+      break;
+    case 138 : {
+      obj_672X = SvalS;
+      if ((3 == (3 & obj_672X))) {
+        if ((2 == (31 & ((((*((long *) ((((char *) (-3 + obj_672X))) + -4))))>>2))))) {
+          if ((((((3 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + (SvalS)))) + -4))))>>8))))>>2)) < 5)) {
+            goto L19494;}
+          else {
+            temp_673X = Sinterrupt_handlersS;
+            Sinterrupt_handlersS = (SvalS);
+            SvalS = temp_673X;
+            Scode_pointerS = ((Scode_pointerS) + 1);
+            arg1K0 = (Scode_pointerS);
+            goto L18438;}}
+        else {
+          goto L19494;}}
+      else {
+        goto L19494;}}
+      break;
+    case 139 : {
+      old_674X = Senabled_interruptsS;
+      p_675X = SvalS;
+      Senabled_interruptsS = (((p_675X)>>2));
+      if ((0 == ((Spending_interruptsS) & (Senabled_interruptsS)))) {
+        s48_Spending_interruptPS = 0;
+        if ((s48_Spending_eventsPS)) {
+          s48_Spending_interruptPS = 1;
+          goto L38655;}
+        else {
+          goto L38655;}}
+      else {
+        s48_Spending_interruptPS = 1;
+        goto L38655;}}
+      break;
+    case 140 : {
+      SstackS = ((SstackS) + 4);
+      p_676X = *((long *) (SstackS));
+      Senabled_interruptsS = (((p_676X)>>2));
+      if ((0 == ((Spending_interruptsS) & (Senabled_interruptsS)))) {
+        s48_Spending_interruptPS = 0;
+        if ((s48_Spending_eventsPS)) {
+          s48_Spending_interruptPS = 1;
+          goto L18452;}
+        else {
+          goto L18452;}}
+      else {
+        s48_Spending_interruptPS = 1;
+        goto L18452;}}
+      break;
+    case 141 : {
+      if ((0 == (3 & (SvalS)))) {
+        p_677X = SvalS;
+        Spending_interruptsS = (-2 & (Spending_interruptsS));
+        if ((0 == ((Spending_interruptsS) & (Senabled_interruptsS)))) {
+          s48_Spending_interruptPS = 0;
+          if ((s48_Spending_eventsPS)) {
+            s48_Spending_interruptPS = 1;
+            goto L37163;}
+          else {
+            goto L37163;}}
+        else {
+          s48_Spending_interruptPS = 1;
+          goto L37163;}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = (SvalS);
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 1;
+        goto L16665;}}
+      break;
+    case 142 : {
+      SstackS = ((SstackS) + 4);
+      arg2_678X = *((long *) (SstackS));
+      if ((0 == (3 & arg2_678X))) {
+        x_679X = SvalS;
+        if ((1 == x_679X)) {
+          goto L34103;}
+        else {
+          if ((5 == x_679X)) {
+            goto L34103;}
+          else {
+            goto L34108;}}}
+      else {
+        goto L34108;}}
+      break;
+    case 143 : {
+      SstackS = ((SstackS) + 4);
+      nargs_680X = (((*((long *) (SstackS))))>>2);
+      SstackS = ((SstackS) + 4);
+      p_681X = *((long *) (SstackS));
+      SstackS = ((SstackS) + 4);
+      rest_list_682X = *((long *) (SstackS));
+      if ((12 < nargs_680X)) {
+        push_exception_continuationB(20, (1 + (*((long *) ((SstackS) + (-4 & p_681X))))));
+        *((long *) (SstackS)) = nargs_680X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 1;
+        goto L16665;}
+      else {
+        arg0K0 = rest_list_682X;
+        goto L22787;}}
+      break;
+    case 144 : {
+      v_683X = AVAILABLEp(5);
+      if (v_683X) {
+        arg2K0 = 1;
+        arg0K1 = 0;
+        goto L33402;}
+      else {
+        collect_saving_temps(1, 1, &temp1_684X);
+        v_685X = AVAILABLEp(5);
+        if (v_685X) {
+          arg2K0 = 1;
+          arg0K1 = 0;
+          goto L33402;}
+        else {
+          arg2K0 = 0;
+          arg0K1 = 0;
+          goto L33402;}}}
+      break;
+    case 146 : {
+      SstackS = ((SstackS) + 4);
+      arg2_686X = *((long *) (SstackS));
+      if ((3 == (3 & arg2_686X))) {
+        if ((16 == (31 & ((((*((long *) ((((char *) (-3 + arg2_686X))) + -4))))>>2))))) {
+          x_687X = SvalS;
+          if ((1 == x_687X)) {
+            goto L23905;}
+          else {
+            if ((5 == x_687X)) {
+              goto L23905;}
+            else {
+              goto L23910;}}}
+        else {
+          goto L23910;}}
+      else {
+        goto L23910;}}
+      break;
+    case 147 : {
+      SstackS = ((SstackS) + 4);
+      arg2_688X = *((long *) (SstackS));
+      if ((0 == (3 & arg2_688X))) {
+        option_689X = ((arg2_688X)>>2);
+        other_690X = SvalS;
+        if ((2 == option_689X)) {
+          x_691X = CHEAP_TIME();
+          SvalS = (((x_691X)<<2));
+          Scode_pointerS = ((Scode_pointerS) + 1);
+          arg1K0 = (Scode_pointerS);
+          goto L18438;}
+        else {
+          if ((0 == option_689X)) {
+            seconds_692X = s48_run_time(&mseconds_693X);
+            arg0K0 = option_689X;
+            arg0K1 = seconds_692X;
+            arg0K2 = mseconds_693X;
+            goto L35318;}
+          else {
+            if ((1 == option_689X)) {
+              seconds_694X = s48_real_time(&mseconds_695X);
+              arg0K0 = option_689X;
+              arg0K1 = seconds_694X;
+              arg0K2 = mseconds_695X;
+              goto L35318;}
+            else {
+              push_exception_continuationB(18, 1);
+              *((long *) (SstackS)) = (((option_689X)<<2));
+              SstackS = ((SstackS) + -4);
+              *((long *) (SstackS)) = other_690X;
+              SstackS = ((SstackS) + -4);
+              arg0K0 = 2;
+              goto L16665;}}}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = arg2_688X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = (SvalS);
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+      break;
+    case 148 : {
+      SstackS = ((SstackS) + 4);
+      arg2_696X = *((long *) (SstackS));
+      if ((0 == (3 & arg2_696X))) {
+        key_697X = ((arg2_696X)>>2);
+        value_698X = SvalS;
+        status_699X = s48_extended_vm(key_697X, value_698X);
+        if ((0 == status_699X)) {
+          SvalS = (s48_Sextension_valueS);
+          Scode_pointerS = ((Scode_pointerS) + 1);
+          arg1K0 = (Scode_pointerS);
+          goto L18438;}
+        else {
+          if ((1 == status_699X)) {
+            push_exception_continuationB(23, 1);
+            *((long *) (SstackS)) = (((key_697X)<<2));
+            SstackS = ((SstackS) + -4);
+            *((long *) (SstackS)) = value_698X;
+            SstackS = ((SstackS) + -4);
+            arg0K0 = 2;
+            goto L16665;}
+          else {
+            push_exception_continuationB(24, 1);
+            *((long *) (SstackS)) = (((key_697X)<<2));
+            SstackS = ((SstackS) + -4);
+            *((long *) (SstackS)) = value_698X;
+            SstackS = ((SstackS) + -4);
+            arg0K0 = 2;
+            goto L16665;}}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = arg2_696X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = (SvalS);
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+      break;
+    case 149 : {
+      SstackS = ((SstackS) + 4);
+      arg2_700X = *((long *) (SstackS));
+      x_701X = SvalS;
+      Senabled_interruptsS = -1;
+      if ((0 == ((Spending_interruptsS) & (Senabled_interruptsS)))) {
+        s48_Spending_interruptPS = 0;
+        if ((s48_Spending_eventsPS)) {
+          s48_Spending_interruptPS = 1;
+          goto L38715;}
+        else {
+          goto L38715;}}
+      else {
+        s48_Spending_interruptPS = 1;
+        goto L38715;}}
+      break;
+    case 150 : {
+      SstackS = ((SstackS) + 4);
+      arg2_702X = *((long *) (SstackS));
+      if ((3 == (3 & arg2_702X))) {
+        if ((16 == (31 & ((((*((long *) ((((char *) (-3 + arg2_702X))) + -4))))>>2))))) {
+          obj_703X = SvalS;
+          if ((3 == (3 & obj_703X))) {
+            if ((16 == (31 & ((((*((long *) ((((char *) (-3 + obj_703X))) + -4))))>>2))))) {
+              x_704X = SvalS;
+              len_705X = (long)(((unsigned long)(*((long *) ((((char *) (-3 + arg2_702X))) + -4))))>>8);
+              if ((len_705X == ((long)(((unsigned long)(*((long *) ((((char *) (-3 + x_704X))) + -4))))>>8)))) {
+                if (((!memcmp((void *)(((char *) (-3 + x_704X))), (void *)(((char *) (-3 + arg2_702X))),len_705X)))) {
+                  arg0K0 = 5;
+                  goto L27842;}
+                else {
+                  arg0K0 = 1;
+                  goto L27842;}}
+              else {
+                arg0K0 = 1;
+                goto L27842;}}
+            else {
+              goto L27809;}}
+          else {
+            goto L27809;}}
+        else {
+          goto L27809;}}
+      else {
+        goto L27809;}}
+      break;
+    case 151 : {
+      space_706X = 1 + ((((4 + ((((SvalS))>>2))))>>2));
+      v_707X = AVAILABLEp(space_706X);
+      if (v_707X) {
+        goto L33611;}
+      else {
+        collect_saving_temps(1, 1, &temp1_708X);
+        v_709X = AVAILABLEp(space_706X);
+        if (v_709X) {
+          goto L33611;}
+        else {
+          ps_error("Scheme48 heap overflow", 0);
+          goto L33611;}}}
+      break;
+    case 152 : {
+      SstackS = ((SstackS) + 4);
+      thing_710X = *((long *) (SstackS));
+      list_711X = SvalS;
+      arg0K0 = list_711X;
+      arg0K1 = list_711X;
+      arg2K2 = 1;
+      goto L29199;}
+      break;
+    case 153 : {
+      SstackS = ((SstackS) + 4);
+      arg2_712X = *((long *) (SstackS));
+      SstackS = ((SstackS) + 4);
+      arg3_713X = *((long *) (SstackS));
+      if ((0 == (3 & (SvalS)))) {
+        index_714X = (((SvalS))>>2);
+        if ((3 == (3 & arg3_713X))) {
+          if ((8 == (31 & ((((*((long *) ((((char *) (-3 + arg3_713X))) + -4))))>>2))))) {
+            if ((arg2_712X == (*((long *) (((char *) (-3 + arg3_713X))))))) {
+              len_715X = (((3 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + arg3_713X))) + -4))))>>8))))>>2);
+              if ((index_714X < 0)) {
+                goto L27515;}
+              else {
+                if ((index_714X < len_715X)) {
+                  SvalS = (*((long *) ((((char *) (-3 + arg3_713X))) + (((index_714X)<<2)))));
+                  Scode_pointerS = ((Scode_pointerS) + 1);
+                  arg1K0 = (Scode_pointerS);
+                  goto L18438;}
+                else {
+                  goto L27515;}}}
+            else {
+              goto L27535;}}
+          else {
+            goto L27535;}}
+        else {
+          goto L27535;}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = arg3_713X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = arg2_712X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = (SvalS);
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 3;
+        goto L16665;}}
+      break;
+    case 154 : {
+      SstackS = ((SstackS) + 4);
+      arg2_716X = *((long *) (SstackS));
+      SstackS = ((SstackS) + 4);
+      arg3_717X = *((long *) (SstackS));
+      SstackS = ((SstackS) + 4);
+      arg4_718X = *((long *) (SstackS));
+      if ((0 == (3 & arg2_716X))) {
+        index_719X = ((arg2_716X)>>2);
+        value_720X = SvalS;
+        if ((3 == (3 & arg4_718X))) {
+          if ((8 == (31 & ((((*((long *) ((((char *) (-3 + arg4_718X))) + -4))))>>2))))) {
+            if ((arg3_717X == (*((long *) (((char *) (-3 + arg4_718X))))))) {
+              if ((3 == (3 & arg4_718X))) {
+                if ((0 == (128 & (*((long *) ((((char *) (-3 + arg4_718X))) + -4)))))) {
+                  len_721X = (((3 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + arg4_718X))) + -4))))>>8))))>>2);
+                  if ((index_719X < 0)) {
+                    goto L30704;}
+                  else {
+                    if ((index_719X < len_721X)) {
+                      addr_722X = (((char *) (-3 + arg4_718X))) + (((index_719X)<<2));
+                      S48_WRITE_BARRIER(arg4_718X, addr_722X, value_720X);
+                      *((long *) addr_722X) = value_720X;
+                      SvalS = 13;
+                      Scode_pointerS = ((Scode_pointerS) + 1);
+                      arg1K0 = (Scode_pointerS);
+                      goto L18438;}
+                    else {
+                      goto L30704;}}}
+                else {
+                  goto L30726;}}
+              else {
+                goto L30726;}}
+            else {
+              goto L30726;}}
+          else {
+            goto L30726;}}
+        else {
+          goto L30726;}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = arg4_718X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = arg3_717X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = arg2_716X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = (SvalS);
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 4;
+        goto L16665;}}
+      break;
+    case 155 : {
+      SstackS = ((SstackS) + 4);
+      arg2_723X = *((long *) (SstackS));
+      SstackS = ((SstackS) + 4);
+      arg3_724X = *((long *) (SstackS));
+      SstackS = ((SstackS) + 4);
+      arg4_725X = *((long *) (SstackS));
+      SstackS = ((SstackS) + 4);
+      arg5_726X = *((long *) (SstackS));
+      if ((0 == (3 & ((arg4_725X | arg2_723X) | (SvalS))))) {
+        from_index_727X = ((arg4_725X)>>2);
+        to_index_728X = ((arg2_723X)>>2);
+        count_729X = (((SvalS))>>2);
+        if ((3 == (3 & arg5_726X))) {
+          if ((16 == (31 & ((((*((long *) ((((char *) (-3 + arg5_726X))) + -4))))>>2))))) {
+            goto L30955;}
+          else {
+            goto L30950;}}
+        else {
+          goto L30950;}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = arg5_726X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = arg4_725X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = arg3_724X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = arg2_723X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = (SvalS);
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 5;
+        goto L16665;}}
+      break;
+    case 156 : {
+      v_730X = *((unsigned char *) ((Scode_pointerS) + 1));
+      if ((0 == v_730X)) {
+        arg0K0 = (SvalS);
+        goto L23037;}
+      else {
+        merged_arg0K0 = 0;
+        get_current_port_return_tag = 0;
+        goto get_current_port;
+       get_current_port_return_0:
+        v_731X = get_current_port0_return_value;
+        arg0K0 = v_731X;
+        goto L23037;}}
+      break;
+    case 157 : {
+      v_732X = *((unsigned char *) ((Scode_pointerS) + 1));
+      if ((0 == v_732X)) {
+        arg0K0 = (SvalS);
+        goto L23257;}
+      else {
+        merged_arg0K0 = 0;
+        get_current_port_return_tag = 1;
+        goto get_current_port;
+       get_current_port_return_1:
+        v_733X = get_current_port0_return_value;
+        arg0K0 = v_733X;
+        goto L23257;}}
+      break;
+    case 158 : {
+      v_734X = *((unsigned char *) ((Scode_pointerS) + 1));
+      if ((0 == v_734X)) {
+        v_735X = SvalS;
+        SstackS = ((SstackS) + 4);
+        arg0K0 = (*((long *) (SstackS)));
+        arg0K1 = v_735X;
+        goto L23470;}
+      else {
+        merged_arg0K0 = 4;
+        get_current_port_return_tag = 2;
+        goto get_current_port;
+       get_current_port_return_2:
+        v_736X = get_current_port0_return_value;
+        arg0K0 = (SvalS);
+        arg0K1 = v_736X;
+        goto L23470;}}
+      break;
+    case 159 : {
+      x_737X = SvalS;
+      out_738X = stderr;
+      arg0K0 = x_737X;
+      goto L29452;}
+      break;
+  }}
+ L16665: {
+  nargs_739X = arg0K0;
+  opcode_740X = (((*((long *) ((SstackS) + (8 + (((nargs_739X)<<2)))))))>>2);
+  obj_741X = Sexception_handlersS;
+  if ((3 == (3 & obj_741X))) {
+    if ((2 == (31 & ((((*((long *) ((((char *) (-3 + obj_741X))) + -4))))>>2))))) {
+      goto L16724;}
+    else {
+      goto L16797;}}
+  else {
+    goto L16797;}}
+ L23824: {
+  env_742X = arg0K0;
+  i_743X = arg0K1;
+  if ((0 == i_743X)) {
+    SvalS = (*((long *) ((((char *) (-3 + env_742X))) + ((((*((unsigned char *) ((Scode_pointerS) + 2))))<<2)))));
+    if ((529 == (SvalS))) {
+      push_exception_continuationB(0, 3);
+      arg0K0 = 0;
+      goto L16665;}
+    else {
+      Scode_pointerS = ((Scode_pointerS) + 3);
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}}
+  else {
+    arg0K0 = (*((long *) (((char *) (-3 + env_742X)))));
+    arg0K1 = (-1 + i_743X);
+    goto L23824;}}
+ L20247: {
+  env_744X = arg0K0;
+  i_745X = arg0K1;
+  if ((0 == i_745X)) {
+    SvalS = (*((long *) ((((char *) (-3 + env_744X))) + ((((((((*((unsigned char *) ((Scode_pointerS) + 3))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + 4)))))<<2)))));
+    if ((529 == (SvalS))) {
+      push_exception_continuationB(0, 5);
+      arg0K0 = 0;
+      goto L16665;}
+    else {
+      Scode_pointerS = ((Scode_pointerS) + 5);
+      arg1K0 = (Scode_pointerS);
+      goto L18438;}}
+  else {
+    arg0K0 = (*((long *) (((char *) (-3 + env_744X)))));
+    arg0K1 = (-1 + i_745X);
+    goto L20247;}}
+ L20185: {
+  env_746X = arg0K0;
+  i_747X = arg0K1;
+  if ((0 == i_747X)) {
+    index_748X = ((((*((unsigned char *) ((Scode_pointerS) + 3))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + 4)));
+    value_749X = SvalS;
+    addr_750X = (((char *) (-3 + env_746X))) + (((index_748X)<<2));
+    S48_WRITE_BARRIER(env_746X, addr_750X, value_749X);
+    *((long *) addr_750X) = value_749X;
+    SvalS = 13;
+    Scode_pointerS = ((Scode_pointerS) + 5);
+    arg1K0 = (Scode_pointerS);
+    goto L18438;}
+  else {
+    arg0K0 = (*((long *) (((char *) (-3 + env_746X)))));
+    arg0K1 = (-1 + i_747X);
+    goto L20185;}}
+ L20964: {
+  space_751X = arg0K0;
+  v_752X = AVAILABLEp(space_751X);
+  if (v_752X) {
+    arg2K0 = 1;
+    arg0K1 = 0;
+    goto L21038;}
+  else {
+    collect_saving_temps(1, 1, &temp1_753X);
+    v_754X = AVAILABLEp(space_751X);
+    if (v_754X) {
+      arg2K0 = 1;
+      arg0K1 = 0;
+      goto L21038;}
+    else {
+      arg2K0 = 0;
+      arg0K1 = 0;
+      goto L21038;}}}
+ L20971: {
+  env_755X = arg0K0;
+  v_756X = AVAILABLEp(3);
+  if (v_756X) {
+    arg2K0 = 1;
+    arg0K1 = env_755X;
+    goto L20996;}
+  else {
+    temp0_757X = collect_saving_temps(env_755X, 1, &temp1_758X);
+    v_759X = AVAILABLEp(3);
+    if (v_759X) {
+      arg2K0 = 1;
+      arg0K1 = temp0_757X;
+      goto L20996;}
+    else {
+      arg2K0 = 0;
+      arg0K1 = temp0_757X;
+      goto L20996;}}}
+ L20766: {
+  len_760X = ((total_count_393X)<<2);
+  addr_761X = ALLOCATE_SPACE(2, (4 + len_760X));
+  *((long *) addr_761X) = (10 + (((len_760X)<<8)));
+  new_env_762X = 3 + (((long) (addr_761X + 4)));
+  v_763X = *((unsigned char *) ((Scode_pointerS) + 1));
+  if ((0 == v_763X)) {
+    arg0K0 = 0;
+    goto L20780;}
+  else {
+    value_764X = SvalS;
+    addr_765X = ((char *) (-3 + new_env_762X));
+    S48_WRITE_BARRIER(new_env_762X, addr_765X, value_764X);
+    *((long *) addr_765X) = value_764X;
+    arg0K0 = 1;
+    goto L20780;}}
+ L20692: {
+  okayP_766X = arg2K0;
+  key_767X = arg0K1;
+  if (okayP_766X) {
+    arg0K0 = key_767X;
+    goto L20680;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = key_767X;
+    goto L20680;}}
+ L19847: {
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L19882: {
+  SstackS = ((((char *) (-3 + (Sbottom_of_stackS)))) + -8);
+  *((long *) (((char *) (-3 + (Sbottom_of_stackS))))) = cont_402X;
+  ScontS = (Sbottom_of_stackS);
+  goto L19847;}
+ L19848: {
+  if ((1 == cont_402X)) {
+    if ((0 == (3 & (SvalS)))) {
+      s48_Scallback_return_stack_blockS = 1;
+      return ((((SvalS))>>2));}
+    else {
+      goto L19863;}}
+  else {
+    goto L19863;}}
+ L19208: {
+  okayP_768X = arg2K0;
+  key_769X = arg0K1;
+  if (okayP_768X) {
+    arg0K0 = key_769X;
+    goto L19163;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = key_769X;
+    goto L19163;}}
+ L19120: {
+  if ((s48_Spending_interruptPS)) {
+    if ((s48_Spending_eventsPS)) {
+      s48_Spending_eventsPS = 0;
+      check_events_return_tag = 0;
+      goto check_events;
+     check_events_return_0:
+      v_770X = check_events0_return_value;
+      if (v_770X) {
+        arg0K0 = stack_arg_count_403X;
+        goto L16894;}
+      else {
+        goto L19124;}}
+    else {
+      arg0K0 = stack_arg_count_403X;
+      goto L16894;}}
+  else {
+    goto L19124;}}
+ L16066: {
+  stack_arg_count_771X = arg0K0;
+  code_772X = *((long *) (((char *) (-3 + (*((long *) (((char *) (-3 + (SvalS))))))))));
+  arg0K0 = (*((unsigned char *) ((((char *) (-3 + code_772X))) + 1)));
+  arg0K1 = 64;
+  goto L16080;}
+ L17161: {
+  exception_773X = arg0K0;
+  stack_arg_count_774X = arg0K1;
+  list_args_775X = arg0K2;
+  list_arg_count_776X = arg0K3;
+  if (((StemplateS) == (SvalS))) {
+    if ((0 < (Slosing_opcodeS))) {
+      ps_error("wrong number of arguments to exception handler", 1, (Slosing_opcodeS));
+      return v_777X;}
+    else {
+      ps_error("wrong number of arguments to interrupt handler", 1, (0 - (Slosing_opcodeS)));
+      return v_778X;}}
+  else {
+    merged_arg0K0 = list_args_775X;
+    merged_arg0K1 = list_arg_count_776X;
+    copy_listS_return_tag = 0;
+    goto copy_listS;
+   copy_listS_return_0:
+    v_779X = copy_listS0_return_value;
+    merged_arg0K0 = v_779X;
+    merged_arg0K1 = stack_arg_count_774X;
+    pop_args_GlistS_return_tag = 1;
+    goto pop_args_GlistS;
+   pop_args_GlistS_return_1:
+    args_780X = pop_args_GlistS0_return_value;
+    push_exception_continuationB(exception_773X, 0);
+    *((long *) (SstackS)) = (SvalS);
+    SstackS = ((SstackS) + -4);
+    *((long *) (SstackS)) = args_780X;
+    SstackS = ((SstackS) + -4);
+    arg0K0 = 2;
+    goto L16665;}}
+ L17628: {
+  loc_781X = arg1K0;
+  arg_782X = arg1K1;
+  if ((top_of_args_414X < arg_782X)) {
+    *((long *) loc_781X) = (*((long *) arg_782X));
+    arg1K0 = (loc_781X + -4);
+    arg1K1 = (arg_782X + -4);
+    goto L17628;}
+  else {
+    SstackS = loc_781X;
+    obj_783X = SvalS;
+    if ((3 == (3 & obj_783X))) {
+      if ((3 == (31 & ((((*((long *) ((((char *) (-3 + obj_783X))) + -4))))>>2))))) {
+        arg0K0 = nargs_413X;
+        goto L16066;}
+      else {
+        arg0K0 = 3;
+        arg0K1 = nargs_413X;
+        arg0K2 = 25;
+        arg0K3 = 0;
+        goto L17161;}}
+    else {
+      arg0K0 = 3;
+      arg0K1 = nargs_413X;
+      arg0K2 = 25;
+      arg0K3 = 0;
+      goto L17161;}}}
+ L17666: {
+  stack_arg_count_784X = arg0K0;
+  list_args_785X = arg0K1;
+  list_arg_count_786X = arg0K2;
+  if ((0 == list_arg_count_786X)) {
+    obj_787X = SvalS;
+    if ((3 == (3 & obj_787X))) {
+      if ((3 == (31 & ((((*((long *) ((((char *) (-3 + obj_787X))) + -4))))>>2))))) {
+        arg0K0 = stack_arg_count_784X;
+        goto L16066;}
+      else {
+        arg0K0 = 3;
+        arg0K1 = stack_arg_count_784X;
+        arg0K2 = 25;
+        arg0K3 = 0;
+        goto L17161;}}
+    else {
+      arg0K0 = 3;
+      arg0K1 = stack_arg_count_784X;
+      arg0K2 = 25;
+      arg0K3 = 0;
+      goto L17161;}}
+  else {
+    obj_788X = SvalS;
+    if ((3 == (3 & obj_788X))) {
+      if ((3 == (31 & ((((*((long *) ((((char *) (-3 + obj_788X))) + -4))))>>2))))) {
+        code_789X = *((long *) (((char *) (-3 + (*((long *) (((char *) (-3 + (SvalS))))))))));
+        total_arg_count_790X = stack_arg_count_784X + list_arg_count_786X;
+        arg0K0 = (*((unsigned char *) ((((char *) (-3 + code_789X))) + 1)));
+        arg0K1 = 64;
+        goto L16357;}
+      else {
+        arg0K0 = 3;
+        arg0K1 = stack_arg_count_784X;
+        arg0K2 = list_args_785X;
+        arg0K3 = list_arg_count_786X;
+        goto L17161;}}
+    else {
+      arg0K0 = 3;
+      arg0K1 = stack_arg_count_784X;
+      arg0K2 = list_args_785X;
+      arg0K3 = list_arg_count_786X;
+      goto L17161;}}}
+ L11273: {
+  list_args_791X = arg0K0;
+  stack_nargs_792X = arg0K1;
+  merged_arg0K0 = list_args_791X;
+  okay_argument_list_return_tag = 1;
+  goto okay_argument_list;
+ okay_argument_list_return_1:
+  okayP_793X = okay_argument_list0_return_value;
+  list_arg_count_794X = okay_argument_list1_return_value;
+  if (okayP_793X) {
+    SvalS = proc_421X;
+    arg0K0 = stack_nargs_792X;
+    arg0K1 = list_args_791X;
+    arg0K2 = list_arg_count_794X;
+    goto L17666;}
+  else {
+    *((long *) (SstackS)) = list_args_791X;
+    SstackS = ((SstackS) + -4);
+    merged_arg0K0 = 25;
+    merged_arg0K1 = (1 + stack_nargs_792X);
+    pop_args_GlistS_return_tag = 2;
+    goto pop_args_GlistS;
+   pop_args_GlistS_return_2:
+    args_795X = pop_args_GlistS0_return_value;
+    SstackS = ((SstackS) + 4);
+    push_exception_continuationB(5, 0);
+    *((long *) (SstackS)) = proc_421X;
+    SstackS = ((SstackS) + -4);
+    *((long *) (SstackS)) = args_795X;
+    SstackS = ((SstackS) + -4);
+    arg0K0 = 2;
+    goto L16665;}}
+ L11314: {
+  list_796X = arg0K0;
+  follower_797X = arg0K1;
+  if ((25 == list_796X)) {
+    list_args_798X = *((long *) (((char *) (-3 + (*((long *) ((((char *) (-3 + follower_797X))) + 4)))))));
+    addr_799X = (((char *) (-3 + follower_797X))) + 4;
+    S48_WRITE_BARRIER(follower_797X, addr_799X, list_args_798X);
+    *((long *) addr_799X) = list_args_798X;
+    arg0K0 = rest_list_422X;
+    arg0K1 = (-1 + stack_nargs_420X);
+    goto L11273;}
+  else {
+    arg0K0 = (*((long *) ((((char *) (-3 + list_796X))) + 4)));
+    arg0K1 = (*((long *) ((((char *) (-3 + follower_797X))) + 4)));
+    goto L11314;}}
+ L17571: {
+  obj_800X = SvalS;
+  if ((3 == (3 & obj_800X))) {
+    if ((3 == (31 & ((((*((long *) ((((char *) (-3 + obj_800X))) + -4))))>>2))))) {
+      arg0K0 = 0;
+      goto L16066;}
+    else {
+      arg0K0 = 3;
+      arg0K1 = 0;
+      arg0K2 = 25;
+      arg0K3 = 0;
+      goto L17161;}}
+  else {
+    arg0K0 = 3;
+    arg0K1 = 0;
+    arg0K2 = 25;
+    arg0K3 = 0;
+    goto L17161;}}
+ L17578: {
+  SstackS = ((((char *) (-3 + (Sbottom_of_stackS)))) + -8);
+  *((long *) (((char *) (-3 + (Sbottom_of_stackS))))) = cont_423X;
+  ScontS = (Sbottom_of_stackS);
+  goto L17571;}
+ L20427: {
+  stack_nargs_801X = arg0K0;
+  list_args_802X = arg0K1;
+  list_arg_count_803X = arg0K2;
+  if ((1 == stack_nargs_801X)) {
+    SstackS = ((SstackS) + 4);
+    SvalS = (*((long *) (SstackS)));
+    pop_continuationB_return_tag = 1;
+    goto pop_continuationB;
+   pop_continuationB_return_1:
+    arg1K0 = (Scode_pointerS);
+    goto L18438;}
+  else {
+    if (((ScontS) == (Sbottom_of_stackS))) {
+      arg0K0 = (*((long *) (((char *) (-3 + (Sbottom_of_stackS))))));
+      goto L20438;}
+    else {
+      arg0K0 = (ScontS);
+      goto L20438;}}}
+ L18944: {
+  okayP_804X = arg2K0;
+  key_805X = arg0K1;
+  if (okayP_804X) {
+    arg0K0 = key_805X;
+    goto L18932;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = key_805X;
+    goto L18932;}}
+ L18817: {
+  tem_806X = *((long *) ((((char *) (-3 + (StemplateS)))) + ((((((((*((unsigned char *) ((Scode_pointerS) + 1))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + 2)))))<<2))));
+  StemplateS = tem_806X;
+  Scode_pointerS = ((((char *) (-3 + (*((long *) (((char *) (-3 + tem_806X)))))))) + 2);
+  if ((s48_Spending_interruptPS)) {
+    if ((s48_Spending_eventsPS)) {
+      s48_Spending_eventsPS = 0;
+      check_events_return_tag = 1;
+      goto check_events;
+     check_events_return_1:
+      v_807X = check_events0_return_value;
+      if (v_807X) {
+        goto L18826;}
+      else {
+        goto L18829;}}
+    else {
+      goto L18826;}}
+  else {
+    goto L18829;}}
+ L19000: {
+  okayP_808X = arg2K0;
+  key_809X = arg0K1;
+  if (okayP_808X) {
+    arg0K0 = key_809X;
+    goto L18987;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = key_809X;
+    goto L18987;}}
+ L18862: {
+  push_exception_continuationB(5, 4);
+  *((long *) (SstackS)) = (*((long *) ((((char *) (-3 + (StemplateS)))) + ((((((((*((unsigned char *) ((Scode_pointerS) + 1))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + 2)))))<<2)))));
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 1;
+  goto L16665;}
+ L18718: {
+  arg0K0 = (2 + (((max_442X)<<1)));
+  goto L18720;}
+ L18720: {
+  offset_810X = arg0K0;
+  Scode_pointerS = ((Scode_pointerS) + offset_810X);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L19750: {
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L18616: {
+  delta_811X = arg0K0;
+  Scode_pointerS = ((Scode_pointerS) + delta_811X);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L19641: {
+  delta_812X = arg0K0;
+  Scode_pointerS = ((Scode_pointerS) + delta_812X);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L38026: {
+  val_813X = arg0K0;
+  SvalS = val_813X;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L38038: {
+  val_814X = arg0K0;
+  SvalS = val_814X;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L10622: {
+  if ((3 == (3 & x_456X))) {
+    if ((7 == (31 & ((((*((long *) ((((char *) (-3 + x_456X))) + -4))))>>2))))) {
+      arg0K0 = 5;
+      goto L38038;}
+    else {
+      goto L10628;}}
+  else {
+    goto L10628;}}
+ L28391: {
+  SvalS = 5;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L28392: {
+  if ((3 == (3 & n_457X))) {
+    if ((10 == (31 & ((((*((long *) ((((char *) (-3 + n_457X))) + -4))))>>2))))) {
+      push_exception_continuationB(5, 1);
+      *((long *) (SstackS)) = n_457X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 1;
+      goto L16665;}
+    else {
+      goto L28396;}}
+  else {
+    goto L28396;}}
+ L28548: {
+  SvalS = 5;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L28523: {
+  if ((3 == (3 & n_458X))) {
+    if ((7 == (31 & ((((*((long *) ((((char *) (-3 + n_458X))) + -4))))>>2))))) {
+      goto L28548;}
+    else {
+      goto L28537;}}
+  else {
+    goto L28537;}}
+ L28747: {
+  SvalS = 5;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L28722: {
+  if ((3 == (3 & n_459X))) {
+    if ((7 == (31 & ((((*((long *) ((((char *) (-3 + n_459X))) + -4))))>>2))))) {
+      goto L28747;}
+    else {
+      goto L28736;}}
+  else {
+    goto L28736;}}
+ L28946: {
+  SvalS = 5;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L28921: {
+  if ((3 == (3 & n_460X))) {
+    if ((7 == (31 & ((((*((long *) ((((char *) (-3 + n_460X))) + -4))))>>2))))) {
+      goto L28946;}
+    else {
+      goto L28935;}}
+  else {
+    goto L28935;}}
+ L6775: {
+  a_815X = arg0K0;
+  if ((b_470X < 0)) {
+    arg0K0 = (0 - b_470X);
+    goto L6779;}
+  else {
+    arg0K0 = b_470X;
+    goto L6779;}}
+ L7056: {
+  a_816X = arg0K0;
+  if ((b_477X < 0)) {
+    arg0K0 = (0 - b_477X);
+    goto L7060;}
+  else {
+    arg0K0 = b_477X;
+    goto L7060;}}
+ L31744: {
+  val_817X = arg0K0;
+  SvalS = val_817X;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L31822: {
+  val_818X = arg0K0;
+  SvalS = val_818X;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L31900: {
+  val_819X = arg0K0;
+  SvalS = val_819X;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L31978: {
+  val_820X = arg0K0;
+  SvalS = val_820X;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L32056: {
+  val_821X = arg0K0;
+  SvalS = val_821X;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L7233: {
+  a_822X = arg0K0;
+  if ((b_491X < 0)) {
+    arg0K0 = (0 - b_491X);
+    goto L7237;}
+  else {
+    arg0K0 = b_491X;
+    goto L7237;}}
+ L25338: {
+  a_823X = arg0K0;
+  n_824X = ((y_493X)>>2);
+  if ((n_824X < 0)) {
+    arg0K0 = (0 - n_824X);
+    goto L25340;}
+  else {
+    arg0K0 = n_824X;
+    goto L25340;}}
+ L38295: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = x_508X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 1;
+  goto L16665;}
+ L25624: {
+  r_825X = arg0K0;
+  if ((536870911 < r_825X)) {
+    push_exception_continuationB(5, 1);
+    *((long *) (SstackS)) = n_509X;
+    SstackS = ((SstackS) + -4);
+    arg0K0 = 1;
+    goto L16665;}
+  else {
+    SvalS = (((r_825X)<<2));
+    Scode_pointerS = ((Scode_pointerS) + 1);
+    arg1K0 = (Scode_pointerS);
+    goto L18438;}}
+ L25903: {
+  SvalS = (((result_530X)<<2));
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L38383: {
+  val_826X = arg0K0;
+  SvalS = val_826X;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L28166: {
+  val_827X = arg0K0;
+  SvalS = val_827X;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L28139: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = arg2_533X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 2;
+  goto L16665;}
+ L28076: {
+  val_828X = arg0K0;
+  SvalS = val_828X;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L28049: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = arg2_535X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 2;
+  goto L16665;}
+ L32748: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = (((x_537X)<<2));
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 1;
+  goto L16665;}
+ L38412: {
+  val_829X = arg0K0;
+  SvalS = val_829X;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L38426: {
+  value_830X = arg0K0;
+  SvalS = value_830X;
+  Scode_pointerS = ((Scode_pointerS) + 2);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L21229: {
+  push_exception_continuationB(5, 2);
+  *((long *) (SstackS)) = stob_541X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((type_542X)<<2));
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 2;
+  goto L16665;}
+ L21301: {
+  type_831X = *((unsigned char *) ((Scode_pointerS) + 2));
+  len_832X = ((len_543X)<<2);
+  addr_833X = ALLOCATE_SPACE(type_831X, (4 + len_832X));
+  *((long *) addr_833X) = (2 + (((((((len_832X)<<6)) + type_831X))<<2)));
+  new_834X = 3 + (((long) (addr_833X + 4)));
+  if ((len_543X < 1)) {
+    goto L21336;}
+  else {
+    *((long *) ((((char *) (-3 + new_834X))) + (-4 + (((len_543X)<<2))))) = (SvalS);
+    arg0K0 = (-2 + len_543X);
+    goto L21320;}}
+ L21483: {
+  type_835X = *((unsigned char *) ((Scode_pointerS) + 1));
+  len_836X = ((len_548X)<<2);
+  addr_837X = ALLOCATE_SPACE(type_835X, (4 + len_836X));
+  *((long *) addr_837X) = (2 + (((((((len_836X)<<6)) + type_835X))<<2)));
+  new_838X = 3 + (((long) (addr_837X + 4)));
+  SstackS = ((SstackS) + 4);
+  stack_nargs_839X = (((*((long *) (SstackS))))>>2);
+  SstackS = ((SstackS) + 4);
+  rest_list_840X = *((long *) (SstackS));
+  arg0K0 = (-1 + stack_nargs_839X);
+  goto L21505;}
+ L21693: {
+  push_exception_continuationB(5, 3);
+  *((long *) (SstackS)) = stob_553X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((type_555X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((offset_554X)<<2));
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 3;
+  goto L16665;}
+ L21796: {
+  push_exception_continuationB(5, 3);
+  *((long *) (SstackS)) = stob_556X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((type_559X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((offset_558X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = value_557X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 4;
+  goto L16665;}
+ L21981: {
+  push_exception_continuationB(5, 2);
+  *((long *) (SstackS)) = (((type_563X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((len_564X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = init_562X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 3;
+  goto L16665;}
+ L21999: {
+  okayP_841X = arg2K0;
+  init_842X = arg0K1;
+  if (okayP_841X) {
+    len_843X = ((len_564X)<<2);
+    addr_844X = ALLOCATE_SPACE(type_563X, (4 + len_843X));
+    *((long *) addr_844X) = (2 + (((((((len_843X)<<6)) + type_563X))<<2)));
+    value_845X = 3 + (((long) (addr_844X + 4)));
+    arg0K0 = (-1 + len_564X);
+    goto L22028;}
+  else {
+    push_exception_continuationB(8, 2);
+    *((long *) (SstackS)) = (((type_563X)<<2));
+    SstackS = ((SstackS) + -4);
+    *((long *) (SstackS)) = (((len_564X)<<2));
+    SstackS = ((SstackS) + -4);
+    *((long *) (SstackS)) = init_842X;
+    SstackS = ((SstackS) + -4);
+    arg0K0 = 3;
+    goto L16665;}}
+ L22277: {
+  push_exception_continuationB(7, 2);
+  *((long *) (SstackS)) = stob_570X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((type_572X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = index_571X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 3;
+  goto L16665;}
+ L22254: {
+  push_exception_continuationB(5, 2);
+  *((long *) (SstackS)) = stob_570X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((type_572X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = index_571X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 3;
+  goto L16665;}
+ L22517: {
+  push_exception_continuationB(7, 2);
+  *((long *) (SstackS)) = stob_576X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((type_578X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = arg2_575X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = value_577X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 4;
+  goto L16665;}
+ L22492: {
+  push_exception_continuationB(5, 2);
+  *((long *) (SstackS)) = stob_576X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((type_578X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = arg2_575X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = value_577X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 4;
+  goto L16665;}
+ L26074: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = (((len_583X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((init_584X)<<2));
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 2;
+  goto L16665;}
+ L26166: {
+  addr_846X = ALLOCATE_SPACE(17, (4 + len_583X));
+  *((long *) addr_846X) = (70 + (((len_583X)<<8)));
+  vector_847X = 3 + (((long) (addr_846X + 4)));
+  arg0K0 = (-1 + len_583X);
+  goto L26115;}
+ L36239: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 1;
+  goto L16665;}
+ L32854: {
+  push_exception_continuationB(7, 1);
+  *((long *) (SstackS)) = arg2_590X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((index_591X)<<2));
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 2;
+  goto L16665;}
+ L35818: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = arg2_590X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 2;
+  goto L16665;}
+ L29802: {
+  push_exception_continuationB(7, 1);
+  *((long *) (SstackS)) = arg3_594X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((index_595X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((Kchar_596X)<<2));
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 3;
+  goto L16665;}
+ L29781: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = arg3_594X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((index_595X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((Kchar_596X)<<2));
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 3;
+  goto L16665;}
+ L34230: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = arg3_594X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = arg2_593X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 3;
+  goto L16665;}
+ L26308: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = (((len_599X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (9 + ((((init_600X))<<8)));
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 2;
+  goto L16665;}
+ L26400: {
+  len_848X = 1 + len_599X;
+  addr_849X = ALLOCATE_SPACE(16, (4 + len_848X));
+  *((long *) addr_849X) = (66 + (((len_848X)<<8)));
+  string_850X = 3 + (((long) (addr_849X + 4)));
+  *((unsigned char *) ((((char *) (-3 + string_850X))) + len_599X)) = 0;
+  arg0K0 = (-1 + len_599X);
+  goto L26349;}
+ L32935: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = arg2_598X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 2;
+  goto L16665;}
+ L36289: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 1;
+  goto L16665;}
+ L32998: {
+  push_exception_continuationB(7, 1);
+  *((long *) (SstackS)) = arg2_606X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((index_607X)<<2));
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 2;
+  goto L16665;}
+ L35914: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = arg2_606X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 2;
+  goto L16665;}
+ L29957: {
+  push_exception_continuationB(7, 1);
+  *((long *) (SstackS)) = arg3_610X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((index_611X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (9 + ((((Kchar_612X))<<8)));
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 3;
+  goto L16665;}
+ L29936: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = arg3_610X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((index_611X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (9 + ((((Kchar_612X))<<8)));
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 3;
+  goto L16665;}
+ L34356: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = arg3_610X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = arg2_609X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 3;
+  goto L16665;}
+ L24478: {
+  obj_851X = SvalS;
+  if ((3 == (3 & obj_851X))) {
+    if ((16 == (31 & ((((*((long *) ((((char *) (-3 + obj_851X))) + -4))))>>2))))) {
+      table_852X = Sthe_symbol_tableS;
+      string_853X = SvalS;
+      n_854X = -1 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + string_853X))) + -4))))>>8));
+      arg0K0 = 0;
+      arg0K1 = 0;
+      goto L13333;}
+    else {
+      goto L24488;}}
+  else {
+    goto L24488;}}
+ L33976: {
+  val_855X = arg0K0;
+  SvalS = val_855X;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L33957: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 1;
+  goto L16665;}
+ L29544: {
+  if ((1 == (SvalS))) {
+    addr_856X = (((char *) (-3 + arg2_620X))) + 4;
+    S48_WRITE_BARRIER(arg2_620X, addr_856X, 273);
+    *((long *) addr_856X) = 273;
+    goto L29550;}
+  else {
+    if ((17 == (255 & (*((long *) ((((char *) (-3 + arg2_620X))) + 4)))))) {
+      addr_857X = (((char *) (-3 + arg2_620X))) + 4;
+      S48_WRITE_BARRIER(arg2_620X, addr_857X, 529);
+      *((long *) addr_857X) = 529;
+      goto L29550;}
+    else {
+      goto L29550;}}}
+ L29551: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = arg2_620X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 2;
+  goto L16665;}
+ L38498: {
+  val_858X = arg0K0;
+  SvalS = val_858X;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L33080: {
+  SvalS = x_623X;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L33131: {
+  okayP_859X = arg2K0;
+  key_860X = arg0K1;
+  if (okayP_859X) {
+    arg0K0 = key_860X;
+    goto L33097;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = key_860X;
+    goto L33097;}}
+ L34474: {
+  okayP_861X = arg2K0;
+  key_862X = arg0K1;
+  if (okayP_861X) {
+    arg0K0 = key_862X;
+    goto L34456;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = key_862X;
+    goto L34456;}}
+ L37343: {
+  okayP_863X = arg2K0;
+  key_864X = arg0K1;
+  if (okayP_863X) {
+    arg0K0 = key_864X;
+    goto L37273;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = key_864X;
+    goto L37273;}}
+ L37603: {
+  okayP_865X = arg2K0;
+  key_866X = arg0K1;
+  if (okayP_865X) {
+    arg0K0 = key_866X;
+    goto L37545;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = key_866X;
+    goto L37545;}}
+ L33202: {
+  val_867X = arg0K0;
+  SvalS = val_867X;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L8173: {
+  arg0K0 = (*((long *) ((((char *) (-3 + channel_637X))) + 16)));
+  goto L33202;}
+ L8179: {
+  ch_868X = arg0K0;
+  prev_869X = arg0K1;
+  if ((1 == ch_868X)) {
+    addr_870X = (((char *) (-3 + channel_637X))) + 16;
+    S48_WRITE_BARRIER(channel_637X, addr_870X, 1);
+    *((long *) addr_870X) = 1;
+    n_871X = ps_abort_fd_op(((((*((long *) ((((char *) (-3 + channel_637X))) + 8))))>>2)));
+    arg0K0 = (((n_871X)<<2));
+    goto L33202;}
+  else {
+    if ((ch_868X == channel_637X)) {
+      y_872X = Spending_channels_tailS;
+      if ((ch_868X == y_872X)) {
+        Spending_channels_tailS = prev_869X;
+        goto L8203;}
+      else {
+        goto L8203;}}
+    else {
+      arg0K0 = (*((long *) ((((char *) (-3 + ch_868X))) + 12)));
+      arg0K1 = ch_868X;
+      goto L8179;}}}
+ L33185: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 1;
+  goto L16665;}
+ L14777: {
+  arg0K0 = (-1 + (Snumber_of_channelsS));
+  arg0K1 = 25;
+  goto L14784;}
+ L34575: {
+  okayP_873X = arg2K0;
+  key_874X = arg0K1;
+  if (okayP_873X) {
+    arg0K0 = key_874X;
+    goto L34529;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = key_874X;
+    goto L34529;}}
+ L35407: {
+  i_875X = arg0K0;
+  h_876X = arg0K1;
+  if ((i_875X < n_655X)) {
+    arg0K0 = (1 + i_875X);
+    arg0K1 = (h_876X + (((*((unsigned char *) ((((char *) (-3 + x_654X))) + i_875X))))));
+    goto L35407;}
+  else {
+    SvalS = (((h_876X)<<2));
+    Scode_pointerS = ((Scode_pointerS) + 1);
+    arg1K0 = (Scode_pointerS);
+    goto L18438;}}
+ L35384: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 1;
+  goto L16665;}
+ L38564: {
+  SstackS = ((SstackS) + 4);
+  stob_877X = *((long *) (SstackS));
+  proc_878X = SvalS;
+  if ((3 == (3 & stob_877X))) {
+    if ((3 == (3 & proc_878X))) {
+      if ((3 == (31 & ((((*((long *) ((((char *) (-3 + proc_878X))) + -4))))>>2))))) {
+        addr_879X = ALLOCATE_SPACE(0, 12);
+        *((long *) addr_879X) = 2050;
+        x_880X = 3 + (((long) (addr_879X + 4)));
+        *((long *) (((char *) (-3 + x_880X)))) = stob_877X;
+        *((long *) ((((char *) (-3 + x_880X))) + 4)) = proc_878X;
+        b_881X = Sfinalizer_alistS;
+        addr_882X = ALLOCATE_SPACE(0, 12);
+        *((long *) addr_882X) = 2050;
+        x_883X = 3 + (((long) (addr_882X + 4)));
+        *((long *) (((char *) (-3 + x_883X)))) = x_880X;
+        *((long *) ((((char *) (-3 + x_883X))) + 4)) = b_881X;
+        Sfinalizer_alistS = x_883X;
+        SvalS = 13;
+        Scode_pointerS = ((Scode_pointerS) + 1);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}
+      else {
+        goto L30563;}}
+    else {
+      goto L30563;}}
+  else {
+    goto L30563;}}
+ L33293: {
+  firstP_884X = arg2K0;
+  vector_885X = s48_find_all(type_665X);
+  if ((1 == vector_885X)) {
+    if (firstP_884X) {
+      collect_saving_temps(0, 0, &v_886X);
+      arg2K0 = 0;
+      goto L33293;}
+    else {
+      push_exception_continuationB(8, 1);
+      *((long *) (SstackS)) = (((type_665X)<<2));
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 1;
+      goto L16665;}}
+  else {
+    SvalS = vector_885X;
+    Scode_pointerS = ((Scode_pointerS) + 1);
+    arg1K0 = (Scode_pointerS);
+    goto L18438;}}
+ L38614: {
+  firstP_887X = arg2K0;
+  type_888X = arg0K1;
+  vector_889X = s48_find_all_records(type_888X);
+  if ((1 == vector_889X)) {
+    if (firstP_887X) {
+      value_890X = collect_saving_temps(type_888X, 0, &v_891X);
+      arg2K0 = 0;
+      arg0K1 = value_890X;
+      goto L38614;}
+    else {
+      push_exception_continuationB(8, 1);
+      *((long *) (SstackS)) = type_888X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 1;
+      goto L16665;}}
+  else {
+    SvalS = vector_889X;
+    Scode_pointerS = ((Scode_pointerS) + 1);
+    arg1K0 = (Scode_pointerS);
+    goto L18438;}}
+ L20570: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 1;
+  goto L16665;}
+ L19494: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 1;
+  goto L16665;}
+ L38655: {
+  SvalS = (((old_674X)<<2));
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L18452: {
+  SstackS = ((SstackS) + 4);
+  pc_892X = *((long *) (SstackS));
+  SstackS = ((SstackS) + 4);
+  tem_893X = *((long *) (SstackS));
+  StemplateS = tem_893X;
+  Scode_pointerS = ((((char *) (-3 + (*((long *) (((char *) (-3 + tem_893X)))))))) + (((pc_892X)>>2)));
+  SstackS = ((SstackS) + 4);
+  SvalS = (*((long *) (SstackS)));
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L37163: {
+  x_894X = s48_schedule_alarm_interrupt((((p_677X)>>2)));
+  SvalS = (((x_894X)<<2));
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L34103: {
+  if ((1 == (SvalS))) {
+    arg2K0 = 0;
+    goto L34107;}
+  else {
+    arg2K0 = 1;
+    goto L34107;}}
+ L34108: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = arg2_678X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 2;
+  goto L16665;}
+ L22787: {
+  rest_list_895X = arg0K0;
+  if ((25 == rest_list_895X)) {
+    proc_896X = *((long *) ((SstackS) + (((nargs_680X)<<2))));
+    name_897X = *((long *) ((SstackS) + (-4 + (((nargs_680X)<<2)))));
+    args_898X = (SstackS) + 4;
+    *((long *) (SstackS)) = (10 + (((nargs_680X)<<10)));
+    SstackS = ((SstackS) + -4);
+    if ((3 == (3 & name_897X))) {
+      if ((16 == (31 & ((((*((long *) ((((char *) (-3 + name_897X))) + -4))))>>2))))) {
+        if ((3 == (3 & proc_896X))) {
+          if ((17 == (31 & ((((*((long *) ((((char *) (-3 + proc_896X))) + -4))))>>2))))) {
+            if ((4 == ((long)(((unsigned long)(*((long *) ((((char *) (-3 + proc_896X))) + -4))))>>8)))) {
+              result_899X = s48_external_call(proc_896X, name_897X, (-2 + nargs_680X), args_898X);
+              if ((Sexternal_exceptionPS)) {
+                Sexternal_exceptionPS = 0;
+                arg0K0 = (Sexternal_exception_nargsS);
+                goto L16665;}
+              else {
+                SvalS = result_899X;
+                Scode_pointerS = ((Scode_pointerS) + 1);
+                arg1K0 = (Scode_pointerS);
+                goto L18438;}}
+            else {
+              goto L22847;}}
+          else {
+            goto L22847;}}
+        else {
+          goto L22847;}}
+      else {
+        goto L22847;}}
+    else {
+      goto L22847;}}
+  else {
+    *((long *) (SstackS)) = (*((long *) (((char *) (-3 + rest_list_895X)))));
+    SstackS = ((SstackS) + -4);
+    arg0K0 = (*((long *) ((((char *) (-3 + rest_list_895X))) + 4)));
+    goto L22787;}}
+ L33402: {
+  okayP_900X = arg2K0;
+  key_901X = arg0K1;
+  if (okayP_900X) {
+    arg0K0 = key_901X;
+    goto L33368;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = key_901X;
+    goto L33368;}}
+ L23905: {
+  if ((1 == (SvalS))) {
+    arg0K0 = (Sexported_bindingsS);
+    goto L23938;}
+  else {
+    arg0K0 = (Simported_bindingsS);
+    goto L23938;}}
+ L23910: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = arg2_686X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 2;
+  goto L16665;}
+ L35318: {
+  option_902X = arg0K0;
+  seconds_903X = arg0K1;
+  mseconds_904X = arg0K2;
+  if ((536869 < seconds_903X)) {
+    push_exception_continuationB(6, 1);
+    *((long *) (SstackS)) = (((option_902X)<<2));
+    SstackS = ((SstackS) + -4);
+    *((long *) (SstackS)) = (((seconds_903X)<<2));
+    SstackS = ((SstackS) + -4);
+    *((long *) (SstackS)) = (((mseconds_904X)<<2));
+    SstackS = ((SstackS) + -4);
+    arg0K0 = 3;
+    goto L16665;}
+  else {
+    SvalS = (((((1000 * seconds_903X) + mseconds_904X))<<2));
+    Scode_pointerS = ((Scode_pointerS) + 1);
+    arg1K0 = (Scode_pointerS);
+    goto L18438;}}
+ L38715: {
+  s48_Scallback_return_stack_blockS = arg2_700X;
+  return x_701X;}
+ L27842: {
+  val_905X = arg0K0;
+  SvalS = val_905X;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L27809: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = arg2_702X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 2;
+  goto L16665;}
+ L33611: {
+  SstackS = ((SstackS) + 4);
+  arg2_906X = *((long *) (SstackS));
+  if ((0 == (3 & (SvalS)))) {
+    n_907X = (((SvalS))>>2);
+    if ((3 == (3 & arg2_906X))) {
+      if ((0 == (31 & ((((*((long *) ((((char *) (-3 + arg2_906X))) + -4))))>>2))))) {
+        goto L27369;}
+      else {
+        goto L27321;}}
+    else {
+      goto L27321;}}
+  else {
+    push_exception_continuationB(5, 1);
+    *((long *) (SstackS)) = arg2_906X;
+    SstackS = ((SstackS) + -4);
+    *((long *) (SstackS)) = (SvalS);
+    SstackS = ((SstackS) + -4);
+    arg0K0 = 2;
+    goto L16665;}}
+ L29199: {
+  list_908X = arg0K0;
+  slow_909X = arg0K1;
+  move_slowP_910X = arg2K2;
+  if ((25 == list_908X)) {
+    SvalS = 1;
+    Scode_pointerS = ((Scode_pointerS) + 1);
+    arg1K0 = (Scode_pointerS);
+    goto L18438;}
+  else {
+    if ((3 == (3 & list_908X))) {
+      if ((0 == (31 & ((((*((long *) ((((char *) (-3 + list_908X))) + -4))))>>2))))) {
+        head_911X = *((long *) (((char *) (-3 + list_908X))));
+        if ((3 == (3 & head_911X))) {
+          if ((0 == (31 & ((((*((long *) ((((char *) (-3 + head_911X))) + -4))))>>2))))) {
+            if (((*((long *) (((char *) (-3 + head_911X))))) == thing_710X)) {
+              SvalS = head_911X;
+              Scode_pointerS = ((Scode_pointerS) + 1);
+              arg1K0 = (Scode_pointerS);
+              goto L18438;}
+            else {
+              list_912X = *((long *) ((((char *) (-3 + list_908X))) + 4));
+              if ((list_912X == slow_909X)) {
+                push_exception_continuationB(5, 1);
+                *((long *) (SstackS)) = thing_710X;
+                SstackS = ((SstackS) + -4);
+                *((long *) (SstackS)) = list_711X;
+                SstackS = ((SstackS) + -4);
+                arg0K0 = 2;
+                goto L16665;}
+              else {
+                if (move_slowP_910X) {
+                  arg0K0 = list_912X;
+                  arg0K1 = (*((long *) ((((char *) (-3 + slow_909X))) + 4)));
+                  arg2K2 = 0;
+                  goto L29199;}
+                else {
+                  arg0K0 = list_912X;
+                  arg0K1 = slow_909X;
+                  arg2K2 = 1;
+                  goto L29199;}}}}
+          else {
+            push_exception_continuationB(5, 1);
+            *((long *) (SstackS)) = thing_710X;
+            SstackS = ((SstackS) + -4);
+            *((long *) (SstackS)) = list_711X;
+            SstackS = ((SstackS) + -4);
+            arg0K0 = 2;
+            goto L16665;}}
+        else {
+          push_exception_continuationB(5, 1);
+          *((long *) (SstackS)) = thing_710X;
+          SstackS = ((SstackS) + -4);
+          *((long *) (SstackS)) = list_711X;
+          SstackS = ((SstackS) + -4);
+          arg0K0 = 2;
+          goto L16665;}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = thing_710X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = list_711X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+    else {
+      push_exception_continuationB(5, 1);
+      *((long *) (SstackS)) = thing_710X;
+      SstackS = ((SstackS) + -4);
+      *((long *) (SstackS)) = list_711X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 2;
+      goto L16665;}}}
+ L27515: {
+  push_exception_continuationB(7, 1);
+  *((long *) (SstackS)) = arg3_713X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = arg2_712X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((index_714X)<<2));
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 3;
+  goto L16665;}
+ L27535: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = arg3_713X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = arg2_712X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((index_714X)<<2));
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 3;
+  goto L16665;}
+ L30704: {
+  push_exception_continuationB(7, 1);
+  *((long *) (SstackS)) = arg4_718X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = arg3_717X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((index_719X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = value_720X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 4;
+  goto L16665;}
+ L30726: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = arg4_718X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = arg3_717X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((index_719X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = value_720X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 4;
+  goto L16665;}
+ L30955: {
+  if ((3 == (3 & arg5_726X))) {
+    if ((16 == (31 & ((((*((long *) ((((char *) (-3 + arg5_726X))) + -4))))>>2))))) {
+      goto L30968;}
+    else {
+      goto L30963;}}
+  else {
+    goto L30963;}}
+ L30950: {
+  if ((3 == (3 & arg5_726X))) {
+    if ((17 == (31 & ((((*((long *) ((((char *) (-3 + arg5_726X))) + -4))))>>2))))) {
+      goto L30955;}
+    else {
+      goto L31022;}}
+  else {
+    goto L31022;}}
+ L23037: {
+  port_913X = arg0K0;
+  if ((3 == (3 & port_913X))) {
+    if ((6 == (31 & ((((*((long *) ((((char *) (-3 + port_913X))) + -4))))>>2))))) {
+      if ((0 == (4 & ((((*((long *) ((((char *) (-3 + port_913X))) + 4))))>>2))))) {
+        goto L23097;}
+      else {
+        p_914X = *((long *) ((((char *) (-3 + port_913X))) + 24));
+        p_915X = *((long *) ((((char *) (-3 + port_913X))) + 28));
+        b_916X = *((long *) ((((char *) (-3 + port_913X))) + 20));
+        i_917X = ((p_914X)>>2);
+        x_918X = *((long *) ((((char *) (-3 + port_913X))) + 12));
+        if ((5 == x_918X)) {
+          goto L23077;}
+        else {
+          if ((i_917X == (((p_915X)>>2)))) {
+            goto L23077;}
+          else {
+            val_919X = 4 + (((i_917X)<<2));
+            addr_920X = (((char *) (-3 + port_913X))) + 24;
+            S48_WRITE_BARRIER(port_913X, addr_920X, val_919X);
+            *((long *) addr_920X) = val_919X;
+            SvalS = (9 + ((((((*((unsigned char *) ((((char *) (-3 + b_916X))) + i_917X))))))<<8)));
+            Scode_pointerS = ((Scode_pointerS) + 2);
+            arg1K0 = (Scode_pointerS);
+            goto L18438;}}}}
+    else {
+      goto L23097;}}
+  else {
+    goto L23097;}}
+ L23257: {
+  port_921X = arg0K0;
+  if ((3 == (3 & port_921X))) {
+    if ((6 == (31 & ((((*((long *) ((((char *) (-3 + port_921X))) + -4))))>>2))))) {
+      if ((0 == (4 & ((((*((long *) ((((char *) (-3 + port_921X))) + 4))))>>2))))) {
+        goto L23317;}
+      else {
+        p_922X = *((long *) ((((char *) (-3 + port_921X))) + 24));
+        p_923X = *((long *) ((((char *) (-3 + port_921X))) + 28));
+        b_924X = *((long *) ((((char *) (-3 + port_921X))) + 20));
+        i_925X = ((p_922X)>>2);
+        x_926X = *((long *) ((((char *) (-3 + port_921X))) + 12));
+        if ((5 == x_926X)) {
+          goto L23297;}
+        else {
+          if ((i_925X == (((p_923X)>>2)))) {
+            goto L23297;}
+          else {
+            SvalS = (9 + ((((((*((unsigned char *) ((((char *) (-3 + b_924X))) + i_925X))))))<<8)));
+            Scode_pointerS = ((Scode_pointerS) + 2);
+            arg1K0 = (Scode_pointerS);
+            goto L18438;}}}}
+    else {
+      goto L23317;}}
+  else {
+    goto L23317;}}
+ L23470: {
+  Kchar_927X = arg0K0;
+  port_928X = arg0K1;
+  if ((9 == (255 & Kchar_927X))) {
+    if ((3 == (3 & port_928X))) {
+      if ((6 == (31 & ((((*((long *) ((((char *) (-3 + port_928X))) + -4))))>>2))))) {
+        if ((0 == (8 & ((((*((long *) ((((char *) (-3 + port_928X))) + 4))))>>2))))) {
+          goto L23531;}
+        else {
+          p_929X = *((long *) ((((char *) (-3 + port_928X))) + 24));
+          b_930X = *((long *) ((((char *) (-3 + port_928X))) + 20));
+          i_931X = ((p_929X)>>2);
+          x_932X = *((long *) ((((char *) (-3 + port_928X))) + 12));
+          if ((5 == x_932X)) {
+            goto L23513;}
+          else {
+            if ((i_931X == ((long)(((unsigned long)(*((long *) ((((char *) (-3 + b_930X))) + -4))))>>8)))) {
+              goto L23513;}
+            else {
+              val_933X = 4 + (((i_931X)<<2));
+              addr_934X = (((char *) (-3 + port_928X))) + 24;
+              S48_WRITE_BARRIER(port_928X, addr_934X, val_933X);
+              *((long *) addr_934X) = val_933X;
+              *((unsigned char *) ((((char *) (-3 + (*((long *) ((((char *) (-3 + port_928X))) + 20)))))) + i_931X)) = (((((Kchar_927X)>>8))));
+              SvalS = 13;
+              Scode_pointerS = ((Scode_pointerS) + 2);
+              arg1K0 = (Scode_pointerS);
+              goto L18438;}}}}
+      else {
+        goto L23531;}}
+    else {
+      goto L23531;}}
+  else {
+    goto L23531;}}
+ L29452: {
+  stuff_935X = arg0K0;
+  if ((3 == (3 & stuff_935X))) {
+    if ((0 == (31 & ((((*((long *) ((((char *) (-3 + stuff_935X))) + -4))))>>2))))) {
+      thing_936X = *((long *) (((char *) (-3 + stuff_935X))));
+      if ((0 == (3 & thing_936X))) {
+        ps_write_integer((((thing_936X)>>2)), out_738X);
+        goto L29458;}
+      else {
+        if ((9 == (255 & thing_936X))) {
+          ps_write_string("#\\", out_738X);
+          { long ignoreXX;
+          PS_WRITE_CHAR(((((thing_936X)>>8))), out_738X, ignoreXX) }
+          goto L29458;}
+        else {
+          if ((3 == (3 & thing_936X))) {
+            if ((8 == (31 & ((((*((long *) ((((char *) (-3 + thing_936X))) + -4))))>>2))))) {
+              if ((0 < ((((3 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + thing_936X))) + -4))))>>8))))>>2)))) {
+                type_937X = *((long *) (((char *) (-3 + thing_936X))));
+                if ((3 == (3 & type_937X))) {
+                  if ((8 == (31 & ((((*((long *) ((((char *) (-3 + type_937X))) + -4))))>>2))))) {
+                    if ((2 < ((((3 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + type_937X))) + -4))))>>8))))>>2)))) {
+                      obj_938X = *((long *) ((((char *) (-3 + type_937X))) + 8));
+                      if ((3 == (3 & obj_938X))) {
+                        if ((1 == (31 & ((((*((long *) ((((char *) (-3 + obj_938X))) + -4))))>>2))))) {
+                          ps_write_string("#{", out_738X);
+                          ps_write_string((((char *)(((char *) (-3 + (*((long *) (((char *) (-3 + (*((long *) ((((char *) (-3 + (*((long *) (((char *) (-3 + thing_936X)))))))) + 8))))))))))))), out_738X);
+                          { long ignoreXX;
+                          PS_WRITE_CHAR(125, out_738X, ignoreXX) }
+                          goto L29458;}
+                        else {
+                          goto L11650;}}
+                      else {
+                        goto L11650;}}
+                    else {
+                      goto L11650;}}
+                  else {
+                    goto L11650;}}
+                else {
+                  goto L11650;}}
+              else {
+                goto L11650;}}
+            else {
+              goto L11650;}}
+          else {
+            goto L11650;}}}}
+    else {
+      goto L29443;}}
+  else {
+    goto L29443;}}
+ L16724: {
+  SvalS = (*((long *) ((((char *) (-3 + (Sexception_handlersS)))) + (((opcode_740X)<<2)))));
+  obj_939X = SvalS;
+  if ((3 == (3 & obj_939X))) {
+    if ((3 == (31 & ((((*((long *) ((((char *) (-3 + obj_939X))) + -4))))>>2))))) {
+      goto L16741;}
+    else {
+      goto L16811;}}
+  else {
+    goto L16811;}}
+ L16797: {
+  merged_arg3K0 = "exception-handlers is not a vector";
+  loseD0_return_tag = 0;
+  goto loseD0;
+ loseD0_return_0:
+  goto L16724;}
+ L21038: {
+  okayP_940X = arg2K0;
+  key_941X = arg0K1;
+  if (okayP_940X) {
+    arg0K0 = key_941X;
+    goto L20966;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = key_941X;
+    goto L20966;}}
+ L20996: {
+  okayP_942X = arg2K0;
+  temp_943X = arg0K1;
+  if (okayP_942X) {
+    arg0K0 = temp_943X;
+    goto L20977;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = temp_943X;
+    goto L20977;}}
+ L20780: {
+  start_i_944X = arg0K0;
+  arg0K0 = start_i_944X;
+  arg0K1 = 2;
+  arg0K2 = (SenvS);
+  goto L20788;}
+ L20680: {
+  key_945X = arg0K0;
+  if ((1 == (ScontS))) {
+    arg0K0 = 1;
+    goto L20684;}
+  else {
+    merged_arg0K0 = key_945X;
+    merged_arg0K1 = 2;
+    really_preserve_continuation_return_tag = 0;
+    goto really_preserve_continuation;
+   really_preserve_continuation_return_0:
+    v_946X = really_preserve_continuation0_return_value;
+    arg0K0 = v_946X;
+    goto L20684;}}
+ L19863: {
+  SstackS = ((((char *) (-3 + (Sbottom_of_stackS)))) + -8);
+  *((long *) (((char *) (-3 + (Sbottom_of_stackS))))) = 1;
+  ScontS = (Sbottom_of_stackS);
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = cont_402X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 2;
+  goto L16665;}
+ L19163: {
+  v_947X = arg0K0;
+  merged_arg0K0 = v_947X;
+  copy_stack_into_heap_return_tag = 0;
+  goto copy_stack_into_heap;
+ copy_stack_into_heap_return_0:
+  if (((SstackS) < (Sstack_limitS))) {
+    ps_error("Couldn't get default procedure space (how can this happen?)", 0);
+    goto L19120;}
+  else {
+    goto L19120;}}
+ L16894: {
+  stack_arg_count_948X = arg0K0;
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (StemplateS);
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((((Scode_pointerS) - (((char *) (-3 + (*((long *) (((char *) (-3 + (StemplateS)))))))))))<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = ((((Senabled_interruptsS))<<2));
+  SstackS = ((SstackS) + -4);
+  tem_949X = Sinterrupt_templateS;
+  StemplateS = tem_949X;
+  Scode_pointerS = (((char *) (-3 + (*((long *) (((char *) (-3 + tem_949X))))))));
+  push_continuationB((Scode_pointerS), (4 + stack_arg_count_948X));
+  n_950X = (Spending_interruptsS) & (Senabled_interruptsS);
+  arg0K0 = 0;
+  arg0K1 = 1;
+  goto L16999;}
+ L19124: {
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L16080: {
+  protocol_951X = arg0K0;
+  stack_space_952X = arg0K1;
+  if ((68 == protocol_951X)) {
+    if ((stack_arg_count_771X < 3)) {
+      skip_953X = *((unsigned char *) ((((char *) (-3 + code_772X))) + (2 + stack_arg_count_771X)));
+      if ((0 == skip_953X)) {
+        arg0K0 = 4;
+        arg0K1 = stack_arg_count_771X;
+        arg0K2 = 25;
+        arg0K3 = 0;
+        goto L17161;}
+      else {
+        arg0K0 = skip_953X;
+        arg0K1 = stack_arg_count_771X;
+        goto L16084;}}
+    else {
+      skip_954X = *((unsigned char *) ((((char *) (-3 + code_772X))) + 5));
+      if ((0 == skip_954X)) {
+        arg0K0 = 4;
+        arg0K1 = stack_arg_count_771X;
+        arg0K2 = 25;
+        arg0K3 = 0;
+        goto L17161;}
+      else {
+        arg0K0 = skip_954X;
+        goto L16107;}}}
+  else {
+    if ((67 == protocol_951X)) {
+      if ((stack_arg_count_771X < (*((unsigned char *) ((((char *) (-3 + code_772X))) + 2))))) {
+        arg0K0 = 4;
+        arg0K1 = stack_arg_count_771X;
+        arg0K2 = 25;
+        arg0K3 = 0;
+        goto L17161;}
+      else {
+        arg0K0 = 3;
+        goto L16107;}}
+    else {
+      if ((65 == protocol_951X)) {
+        wants_stack_args_955X = ((((*((unsigned char *) ((((char *) (-3 + code_772X))) + 2))))<<8)) + (*((unsigned char *) ((((char *) (-3 + code_772X))) + 3)));
+        if ((stack_arg_count_771X < wants_stack_args_955X)) {
+          arg0K0 = 4;
+          arg0K1 = stack_arg_count_771X;
+          arg0K2 = 25;
+          arg0K3 = 0;
+          goto L17161;}
+        else {
+          merged_arg0K0 = wants_stack_args_955X;
+          merged_arg0K1 = stack_arg_count_771X;
+          merged_arg0K2 = 25;
+          merged_arg0K3 = 0;
+          rest_list_setup_return_tag = 0;
+          goto rest_list_setup;
+         rest_list_setup_return_0:
+          arg0K0 = 4;
+          arg0K1 = (1 + wants_stack_args_955X);
+          goto L16084;}}
+      else {
+        if ((63 < protocol_951X)) {
+          if ((64 == protocol_951X)) {
+            if (((((((*((unsigned char *) ((((char *) (-3 + code_772X))) + 2))))<<8)) + (*((unsigned char *) ((((char *) (-3 + code_772X))) + 3)))) == stack_arg_count_771X)) {
+              arg0K0 = 4;
+              arg0K1 = stack_arg_count_771X;
+              goto L16084;}
+            else {
+              arg0K0 = 4;
+              arg0K1 = stack_arg_count_771X;
+              arg0K2 = 25;
+              arg0K3 = 0;
+              goto L17161;}}
+          else {
+            if ((66 == protocol_951X)) {
+              length_956X = (long)(((unsigned long)(*((long *) ((((char *) (-3 + code_772X))) + -4))))>>8);
+              index_957X = -2 + length_956X;
+              arg0K0 = (*((unsigned char *) ((((char *) (-3 + code_772X))) + (-3 + length_956X))));
+              arg0K1 = (((((*((unsigned char *) ((((char *) (-3 + code_772X))) + index_957X))))<<8)) + (*((unsigned char *) ((((char *) (-3 + code_772X))) + (1 + index_957X)))));
+              goto L16080;}
+            else {
+              ps_error("unknown protocol", 1, protocol_951X);
+              arg0K0 = 4;
+              arg0K1 = stack_arg_count_771X;
+              arg0K2 = 25;
+              arg0K3 = 0;
+              goto L17161;}}}
+        else {
+          if ((protocol_951X == stack_arg_count_771X)) {
+            arg0K0 = 2;
+            arg0K1 = stack_arg_count_771X;
+            goto L16084;}
+          else {
+            arg0K0 = 4;
+            arg0K1 = stack_arg_count_771X;
+            arg0K2 = 25;
+            arg0K3 = 0;
+            goto L17161;}}}}}}
+ L16357: {
+  protocol_958X = arg0K0;
+  stack_space_959X = arg0K1;
+  if ((68 == protocol_958X)) {
+    if ((total_arg_count_790X < 3)) {
+      skip_960X = *((unsigned char *) ((((char *) (-3 + code_789X))) + (2 + total_arg_count_790X)));
+      if ((0 == skip_960X)) {
+        arg0K0 = 4;
+        arg0K1 = stack_arg_count_784X;
+        arg0K2 = list_args_785X;
+        arg0K3 = list_arg_count_786X;
+        goto L17161;}
+      else {
+        merged_arg0K0 = list_args_785X;
+        merged_arg0K1 = list_arg_count_786X;
+        push_list_return_tag = 0;
+        goto push_list;
+       push_list_return_0:
+        arg0K0 = skip_960X;
+        arg0K1 = total_arg_count_790X;
+        goto L16361;}}
+    else {
+      skip_961X = *((unsigned char *) ((((char *) (-3 + code_789X))) + 5));
+      if ((0 == skip_961X)) {
+        arg0K0 = 4;
+        arg0K1 = stack_arg_count_784X;
+        arg0K2 = list_args_785X;
+        arg0K3 = list_arg_count_786X;
+        goto L17161;}
+      else {
+        arg0K0 = skip_961X;
+        goto L16386;}}}
+  else {
+    if ((67 == protocol_958X)) {
+      if ((total_arg_count_790X < (*((unsigned char *) ((((char *) (-3 + code_789X))) + 2))))) {
+        arg0K0 = 4;
+        arg0K1 = stack_arg_count_784X;
+        arg0K2 = list_args_785X;
+        arg0K3 = list_arg_count_786X;
+        goto L17161;}
+      else {
+        arg0K0 = 3;
+        goto L16386;}}
+    else {
+      if ((63 < protocol_958X)) {
+        if ((65 == protocol_958X)) {
+          wants_stack_args_962X = ((((*((unsigned char *) ((((char *) (-3 + code_789X))) + 2))))<<8)) + (*((unsigned char *) ((((char *) (-3 + code_789X))) + 3)));
+          if ((total_arg_count_790X < wants_stack_args_962X)) {
+            arg0K0 = 4;
+            arg0K1 = stack_arg_count_784X;
+            arg0K2 = list_args_785X;
+            arg0K3 = list_arg_count_786X;
+            goto L17161;}
+          else {
+            merged_arg0K0 = wants_stack_args_962X;
+            merged_arg0K1 = stack_arg_count_784X;
+            merged_arg0K2 = list_args_785X;
+            merged_arg0K3 = list_arg_count_786X;
+            rest_list_setup_return_tag = 1;
+            goto rest_list_setup;
+           rest_list_setup_return_1:
+            arg0K0 = 4;
+            arg0K1 = (1 + wants_stack_args_962X);
+            goto L16361;}}
+        else {
+          if ((64 == protocol_958X)) {
+            if (((((((*((unsigned char *) ((((char *) (-3 + code_789X))) + 2))))<<8)) + (*((unsigned char *) ((((char *) (-3 + code_789X))) + 3)))) == total_arg_count_790X)) {
+              merged_arg0K0 = list_args_785X;
+              merged_arg0K1 = list_arg_count_786X;
+              push_list_return_tag = 1;
+              goto push_list;
+             push_list_return_1:
+              arg0K0 = 4;
+              arg0K1 = total_arg_count_790X;
+              goto L16361;}
+            else {
+              arg0K0 = 4;
+              arg0K1 = stack_arg_count_784X;
+              arg0K2 = list_args_785X;
+              arg0K3 = list_arg_count_786X;
+              goto L17161;}}
+          else {
+            if ((66 == protocol_958X)) {
+              length_963X = (long)(((unsigned long)(*((long *) ((((char *) (-3 + code_789X))) + -4))))>>8);
+              index_964X = -2 + length_963X;
+              arg0K0 = (*((unsigned char *) ((((char *) (-3 + code_789X))) + (-3 + length_963X))));
+              arg0K1 = (((((*((unsigned char *) ((((char *) (-3 + code_789X))) + index_964X))))<<8)) + (*((unsigned char *) ((((char *) (-3 + code_789X))) + (1 + index_964X)))));
+              goto L16357;}
+            else {
+              ps_error("unknown protocol", 1, protocol_958X);
+              arg0K0 = 4;
+              arg0K1 = stack_arg_count_784X;
+              arg0K2 = list_args_785X;
+              arg0K3 = list_arg_count_786X;
+              goto L17161;}}}}
+      else {
+        if ((protocol_958X == total_arg_count_790X)) {
+          merged_arg0K0 = list_args_785X;
+          merged_arg0K1 = list_arg_count_786X;
+          push_list_return_tag = 2;
+          goto push_list;
+         push_list_return_2:
+          arg0K0 = 2;
+          arg0K1 = total_arg_count_790X;
+          goto L16361;}
+        else {
+          arg0K0 = 4;
+          arg0K1 = stack_arg_count_784X;
+          arg0K2 = list_args_785X;
+          arg0K3 = list_arg_count_786X;
+          goto L17161;}}}}}
+ L20438: {
+  cont_965X = arg0K0;
+  if ((3 == (3 & cont_965X))) {
+    if ((9 == (31 & ((((*((long *) ((((char *) (-3 + cont_965X))) + -4))))>>2))))) {
+      next_op_966X = *((unsigned char *) ((((char *) (-3 + (*((long *) (((char *) (-3 + (*((long *) ((((char *) (-3 + cont_965X))) + 8))))))))))) + ((((*((long *) ((((char *) (-3 + cont_965X))) + 4))))>>2))));
+      if ((34 == next_op_966X)) {
+        pop_continuationB_return_tag = 2;
+        goto pop_continuationB;
+       pop_continuationB_return_2:
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}
+      else {
+        if ((30 == next_op_966X)) {
+          next_967X = *((long *) (((char *) (-3 + (ScontS)))));
+          if (((ScontS) == (Sbottom_of_stackS))) {
+            *((long *) (((char *) (-3 + (ScontS))))) = (*((long *) (((char *) (-3 + next_967X)))));
+            goto L19282;}
+          else {
+            ScontS = next_967X;
+            goto L19282;}}
+        else {
+          merged_arg0K0 = list_args_802X;
+          merged_arg0K1 = stack_nargs_801X;
+          pop_args_GlistS_return_tag = 3;
+          goto pop_args_GlistS;
+         pop_args_GlistS_return_3:
+          args_968X = pop_args_GlistS0_return_value;
+          push_exception_continuationB(4, 0);
+          *((long *) (SstackS)) = 1;
+          SstackS = ((SstackS) + -4);
+          *((long *) (SstackS)) = args_968X;
+          SstackS = ((SstackS) + -4);
+          arg0K0 = 2;
+          goto L16665;}}}
+    else {
+      goto L20444;}}
+  else {
+    goto L20444;}}
+ L18932: {
+  v_969X = arg0K0;
+  merged_arg0K0 = v_969X;
+  copy_stack_into_heap_return_tag = 1;
+  goto copy_stack_into_heap;
+ copy_stack_into_heap_return_1:
+  if (((SstackS) < (Sstack_limitS))) {
+    ps_error("Couldn't get default procedure space (how can this happen?)", 0);
+    goto L18817;}
+  else {
+    goto L18817;}}
+ L18826: {
+  arg0K0 = (*((unsigned char *) ((Scode_pointerS) + 3)));
+  goto L16894;}
+ L18829: {
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L18987: {
+  v_970X = arg0K0;
+  merged_arg0K0 = v_970X;
+  copy_stack_into_heap_return_tag = 2;
+  goto copy_stack_into_heap;
+ copy_stack_into_heap_return_2:
+  if ((space_436X < (64 + (((((SstackS) - (Sstack_limitS)))>>2))))) {
+    goto L18817;}
+  else {
+    ps_error("VM's stack is too small (how can this happen?)", 0);
+    goto L18817;}}
+ L10628: {
+  if ((3 == (3 & x_456X))) {
+    if ((18 == (31 & ((((*((long *) ((((char *) (-3 + x_456X))) + -4))))>>2))))) {
+      arg0K0 = 5;
+      goto L38038;}
+    else {
+      goto L10634;}}
+  else {
+    goto L10634;}}
+ L28396: {
+  SvalS = 1;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L28537: {
+  if ((3 == (3 & n_458X))) {
+    if ((18 == (31 & ((((*((long *) ((((char *) (-3 + n_458X))) + -4))))>>2))))) {
+      goto L28548;}
+    else {
+      goto L28549;}}
+  else {
+    goto L28549;}}
+ L28736: {
+  if ((3 == (3 & n_459X))) {
+    if ((18 == (31 & ((((*((long *) ((((char *) (-3 + n_459X))) + -4))))>>2))))) {
+      goto L28747;}
+    else {
+      goto L28748;}}
+  else {
+    goto L28748;}}
+ L28935: {
+  if ((3 == (3 & n_460X))) {
+    if ((18 == (31 & ((((*((long *) ((((char *) (-3 + n_460X))) + -4))))>>2))))) {
+      goto L28946;}
+    else {
+      goto L28947;}}
+  else {
+    goto L28947;}}
+ L6779: {
+  b_971X = arg0K0;
+  lo_a_972X = 65535 & a_815X;
+  lo_b_973X = 65535 & b_971X;
+  hi_a_974X = 65535 & (((a_815X)>>16));
+  hi_b_975X = 65535 & (((b_971X)>>16));
+  lo_c_976X = SMALL_MULTIPLY(lo_a_972X, lo_b_973X);
+  v_977X = SMALL_MULTIPLY(lo_b_973X, hi_a_974X);
+  v_978X = SMALL_MULTIPLY(lo_a_972X, hi_b_975X);
+  mid_c_979X = v_978X + v_977X;
+  c_980X = lo_c_976X + (((mid_c_979X)<<16));
+  if ((0 < hi_a_974X)) {
+    if ((0 < hi_b_975X)) {
+      push_exception_continuationB(5, 1);
+      *((long *) (SstackS)) = arg2_467X;
+      SstackS = ((SstackS) + -4);
+      *((long *) (SstackS)) = x_468X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 2;
+      goto L16665;}
+    else {
+      goto L6821;}}
+  else {
+    goto L6821;}}
+ L7060: {
+  b_981X = arg0K0;
+  c_982X = a_816X / b_981X;
+  x_983X = 0 == (a_816X % b_981X);
+  if (x_983X) {
+    if ((a_476X < 0)) {
+      if ((b_477X < 0)) {
+        goto L7115;}
+      else {
+        goto L7114;}}
+    else {
+      if ((b_477X < 0)) {
+        goto L7114;}
+      else {
+        goto L7115;}}}
+  else {
+    push_exception_continuationB(5, 1);
+    *((long *) (SstackS)) = arg2_474X;
+    SstackS = ((SstackS) + -4);
+    *((long *) (SstackS)) = x_475X;
+    SstackS = ((SstackS) + -4);
+    arg0K0 = 2;
+    goto L16665;}}
+ L7237: {
+  b_984X = arg0K0;
+  c_985X = a_822X / b_984X;
+  if ((a_490X < 0)) {
+    if ((b_491X < 0)) {
+      goto L7283;}
+    else {
+      goto L7282;}}
+  else {
+    if ((b_491X < 0)) {
+      goto L7282;}
+    else {
+      goto L7283;}}}
+ L25340: {
+  b_986X = arg0K0;
+  c_987X = a_823X % b_986X;
+  if ((a_494X < 0)) {
+    arg0K0 = (0 - c_987X);
+    goto L25344;}
+  else {
+    arg0K0 = c_987X;
+    goto L25344;}}
+ L21336: {
+  SvalS = new_834X;
+  Scode_pointerS = ((Scode_pointerS) + 3);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L21320: {
+  i_988X = arg0K0;
+  if ((i_988X < 0)) {
+    goto L21336;}
+  else {
+    SstackS = ((SstackS) + 4);
+    *((long *) ((((char *) (-3 + new_834X))) + (((i_988X)<<2)))) = (*((long *) (SstackS)));
+    arg0K0 = (-1 + i_988X);
+    goto L21320;}}
+ L21505: {
+  i_989X = arg0K0;
+  if ((i_989X < 0)) {
+    arg0K0 = stack_nargs_839X;
+    arg0K1 = rest_list_840X;
+    goto L21523;}
+  else {
+    SstackS = ((SstackS) + 4);
+    *((long *) ((((char *) (-3 + new_838X))) + (((i_989X)<<2)))) = (*((long *) (SstackS)));
+    arg0K0 = (-1 + i_989X);
+    goto L21505;}}
+ L22028: {
+  i_990X = arg0K0;
+  if ((i_990X < 0)) {
+    SvalS = value_845X;
+    Scode_pointerS = ((Scode_pointerS) + 2);
+    arg1K0 = (Scode_pointerS);
+    goto L18438;}
+  else {
+    addr_991X = (((char *) (-3 + value_845X))) + (((i_990X)<<2));
+    S48_WRITE_BARRIER(value_845X, addr_991X, init_842X);
+    *((long *) addr_991X) = init_842X;
+    arg0K0 = (-1 + i_990X);
+    goto L22028;}}
+ L26115: {
+  i_992X = arg0K0;
+  if ((i_992X < 0)) {
+    SvalS = vector_847X;
+    Scode_pointerS = ((Scode_pointerS) + 1);
+    arg1K0 = (Scode_pointerS);
+    goto L18438;}
+  else {
+    *((unsigned char *) ((((char *) (-3 + vector_847X))) + i_992X)) = init_584X;
+    arg0K0 = (-1 + i_992X);
+    goto L26115;}}
+ L26349: {
+  i_993X = arg0K0;
+  if ((i_993X < 0)) {
+    SvalS = string_850X;
+    Scode_pointerS = ((Scode_pointerS) + 1);
+    arg1K0 = (Scode_pointerS);
+    goto L18438;}
+  else {
+    *((unsigned char *) ((((char *) (-3 + string_850X))) + i_993X)) = (init_600X);
+    arg0K0 = (-1 + i_993X);
+    goto L26349;}}
+ L13333: {
+  i_994X = arg0K0;
+  h_995X = arg0K1;
+  if ((i_994X < n_854X)) {
+    arg0K0 = (1 + i_994X);
+    arg0K1 = (h_995X + (((*((unsigned char *) ((((char *) (-3 + string_853X))) + i_994X))))));
+    goto L13333;}
+  else {
+    index_996X = 1023 & h_995X;
+    bucket_997X = *((long *) ((((char *) (-3 + table_852X))) + (((index_996X)<<2))));
+    arg0K0 = bucket_997X;
+    goto L13301;}}
+ L24488: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 1;
+  goto L16665;}
+ L29550: {
+  SvalS = 13;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L33097: {
+  key_998X = arg0K0;
+  SstackS = ((SstackS) + 4);
+  arg2_999X = *((long *) (SstackS));
+  if ((0 == (3 & (SvalS)))) {
+    mode_1000X = (((SvalS))>>2);
+    if ((1 == mode_1000X)) {
+      goto L26773;}
+    else {
+      if ((2 == mode_1000X)) {
+        goto L26773;}
+      else {
+        if ((3 == mode_1000X)) {
+          goto L26773;}
+        else {
+          if ((4 == mode_1000X)) {
+            goto L26773;}
+          else {
+            push_exception_continuationB(5, 1);
+            *((long *) (SstackS)) = arg2_999X;
+            SstackS = ((SstackS) + -4);
+            *((long *) (SstackS)) = (((mode_1000X)<<2));
+            SstackS = ((SstackS) + -4);
+            arg0K0 = 2;
+            goto L16665;}}}}}
+  else {
+    push_exception_continuationB(5, 1);
+    *((long *) (SstackS)) = arg2_999X;
+    SstackS = ((SstackS) + -4);
+    *((long *) (SstackS)) = (SvalS);
+    SstackS = ((SstackS) + -4);
+    arg0K0 = 2;
+    goto L16665;}}
+ L34456: {
+  key_1001X = arg0K0;
+  obj_1002X = SvalS;
+  if ((3 == (3 & obj_1002X))) {
+    if ((5 == (31 & ((((*((long *) ((((char *) (-3 + obj_1002X))) + -4))))>>2))))) {
+      channel_1003X = SvalS;
+      if ((0 == (*((long *) (((char *) (-3 + channel_1003X))))))) {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = channel_1003X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 1;
+        goto L16665;}
+      else {
+        status_1004X = close_channelB(channel_1003X);
+        if ((status_1004X == NO_ERRORS)) {
+          SvalS = 13;
+          Scode_pointerS = ((Scode_pointerS) + 1);
+          arg1K0 = (Scode_pointerS);
+          goto L18438;}
+        else {
+          push_exception_continuationB(25, 1);
+          *((long *) (SstackS)) = channel_1003X;
+          SstackS = ((SstackS) + -4);
+          merged_arg0K0 = status_1004X;
+          merged_arg0K1 = key_1001X;
+          get_error_string_return_tag = 0;
+          goto get_error_string;
+         get_error_string_return_0:
+          x_1005X = get_error_string0_return_value;
+          *((long *) (SstackS)) = x_1005X;
+          SstackS = ((SstackS) + -4);
+          arg0K0 = 2;
+          goto L16665;}}}
+    else {
+      goto L34464;}}
+  else {
+    goto L34464;}}
+ L37273: {
+  key_1006X = arg0K0;
+  SstackS = ((SstackS) + 4);
+  arg2_1007X = *((long *) (SstackS));
+  SstackS = ((SstackS) + 4);
+  arg3_1008X = *((long *) (SstackS));
+  SstackS = ((SstackS) + 4);
+  arg4_1009X = *((long *) (SstackS));
+  SstackS = ((SstackS) + 4);
+  arg5_1010X = *((long *) (SstackS));
+  if ((0 == (3 & (arg4_1009X | arg3_1008X)))) {
+    if ((1 == arg2_1007X)) {
+      goto L37305;}
+    else {
+      if ((5 == arg2_1007X)) {
+        goto L37305;}
+      else {
+        goto L37325;}}}
+  else {
+    goto L37325;}}
+ L37545: {
+  key_1011X = arg0K0;
+  SstackS = ((SstackS) + 4);
+  arg2_1012X = *((long *) (SstackS));
+  SstackS = ((SstackS) + 4);
+  arg3_1013X = *((long *) (SstackS));
+  SstackS = ((SstackS) + 4);
+  arg4_1014X = *((long *) (SstackS));
+  if ((0 == (3 & (arg3_1013X | arg2_1012X)))) {
+    obj_1015X = SvalS;
+    if ((3 == (3 & obj_1015X))) {
+      if ((5 == (31 & ((((*((long *) ((((char *) (-3 + obj_1015X))) + -4))))>>2))))) {
+        start_1016X = ((arg3_1013X)>>2);
+        count_1017X = ((arg2_1012X)>>2);
+        channel_1018X = SvalS;
+        v_1019X = 8 == (*((long *) (((char *) (-3 + channel_1018X)))));
+        if (v_1019X) {
+          if ((3 == (3 & arg4_1014X))) {
+            if ((16 == (31 & ((((*((long *) ((((char *) (-3 + arg4_1014X))) + -4))))>>2))))) {
+              goto L36856;}
+            else {
+              goto L36848;}}
+          else {
+            goto L36848;}}
+        else {
+          arg0K0 = 5;
+          goto L36739;}}
+      else {
+        goto L37587;}}
+    else {
+      goto L37587;}}
+  else {
+    goto L37587;}}
+ L8203: {
+  val_1020X = *((long *) ((((char *) (-3 + ch_868X))) + 12));
+  addr_1021X = (((char *) (-3 + prev_869X))) + 12;
+  S48_WRITE_BARRIER(prev_869X, addr_1021X, val_1020X);
+  *((long *) addr_1021X) = val_1020X;
+  addr_1022X = (((char *) (-3 + ch_868X))) + 12;
+  S48_WRITE_BARRIER(ch_868X, addr_1022X, 1);
+  *((long *) addr_1022X) = 1;
+  arg0K0 = (*((long *) ((((char *) (-3 + ch_868X))) + 16)));
+  goto L33202;}
+ L14784: {
+  i_1023X = arg0K0;
+  res_1024X = arg0K1;
+  if ((-1 == i_1023X)) {
+    SvalS = res_1024X;
+    Scode_pointerS = ((Scode_pointerS) + 1);
+    arg1K0 = (Scode_pointerS);
+    goto L18438;}
+  else {
+    channel_1025X = *((Svm_channelsS) + i_1023X);
+    if ((3 == (3 & channel_1025X))) {
+      if ((5 == (31 & ((((*((long *) ((((char *) (-3 + channel_1025X))) + -4))))>>2))))) {
+        addr_1026X = ALLOCATE_SPACE(0, 12);
+        *((long *) addr_1026X) = 2050;
+        x_1027X = 3 + (((long) (addr_1026X + 4)));
+        *((long *) (((char *) (-3 + x_1027X)))) = channel_1025X;
+        *((long *) ((((char *) (-3 + x_1027X))) + 4)) = res_1024X;
+        arg0K0 = x_1027X;
+        goto L14798;}
+      else {
+        arg0K0 = res_1024X;
+        goto L14798;}}
+    else {
+      arg0K0 = res_1024X;
+      goto L14798;}}}
+ L34529: {
+  key_1028X = arg0K0;
+  SstackS = ((SstackS) + 4);
+  arg2_1029X = *((long *) (SstackS));
+  SstackS = ((SstackS) + 4);
+  arg3_1030X = *((long *) (SstackS));
+  if ((3 == (3 & arg3_1030X))) {
+    if ((16 == (31 & ((((*((long *) ((((char *) (-3 + arg3_1030X))) + -4))))>>2))))) {
+      obj_1031X = SvalS;
+      if ((3 == (3 & obj_1031X))) {
+        if ((16 == (31 & ((((*((long *) ((((char *) (-3 + obj_1031X))) + -4))))>>2))))) {
+          comment_string_1032X = SvalS;
+          x_1033X = s48_image_writing_okayP();
+          if (x_1033X) {
+            port_1034X = ps_open_output_file((((char *)(((char *) (-3 + arg3_1030X))))), &status_1035X);
+            if ((status_1035X == NO_ERRORS)) {
+              status_1036X = ps_write_string((((char *)(((char *) (-3 + comment_string_1032X))))), port_1034X);
+              if ((status_1036X == NO_ERRORS)) {
+                status_1037X = s48_write_image(arg2_1029X, port_1034X);
+                if ((status_1037X == NO_ERRORS)) {
+                  status_1038X = ps_close(port_1034X);
+                  if ((status_1038X == NO_ERRORS)) {
+                    undumpables_1039X = s48_undumpable_records(&undumpable_count_1040X);
+                    if ((0 == undumpable_count_1040X)) {
+                      SvalS = 13;
+                      Scode_pointerS = ((Scode_pointerS) + 1);
+                      arg1K0 = (Scode_pointerS);
+                      goto L18438;}
+                    else {
+                      push_exception_continuationB(26, 1);
+                      *((long *) (SstackS)) = arg3_1030X;
+                      SstackS = ((SstackS) + -4);
+                      *((long *) (SstackS)) = arg2_1029X;
+                      SstackS = ((SstackS) + -4);
+                      *((long *) (SstackS)) = comment_string_1032X;
+                      SstackS = ((SstackS) + -4);
+                      *((long *) (SstackS)) = undumpables_1039X;
+                      SstackS = ((SstackS) + -4);
+                      *((long *) (SstackS)) = (((undumpable_count_1040X)<<2));
+                      SstackS = ((SstackS) + -4);
+                      arg0K0 = 5;
+                      goto L16665;}}
+                  else {
+                    arg0K0 = 25;
+                    arg0K1 = status_1038X;
+                    goto L30184;}}
+                else {
+                  status_1041X = ps_close(port_1034X);
+                  if ((status_1041X == NO_ERRORS)) {
+                    arg0K0 = 25;
+                    arg0K1 = status_1037X;
+                    goto L30184;}
+                  else {
+                    ps_write_string("Unable to close image file", (stderr));
+                    { long ignoreXX;
+                    PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+                    arg0K0 = 25;
+                    arg0K1 = status_1037X;
+                    goto L30184;}}}
+              else {
+                status_1042X = ps_close(port_1034X);
+                if ((status_1042X == NO_ERRORS)) {
+                  arg0K0 = 25;
+                  arg0K1 = status_1036X;
+                  goto L30184;}
+                else {
+                  ps_write_string("Unable to close image file", (stderr));
+                  { long ignoreXX;
+                  PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+                  arg0K0 = 25;
+                  arg0K1 = status_1036X;
+                  goto L30184;}}}
+            else {
+              arg0K0 = 10;
+              arg0K1 = status_1035X;
+              goto L30184;}}
+          else {
+            push_exception_continuationB(15, 1);
+            *((long *) (SstackS)) = arg3_1030X;
+            SstackS = ((SstackS) + -4);
+            *((long *) (SstackS)) = arg2_1029X;
+            SstackS = ((SstackS) + -4);
+            *((long *) (SstackS)) = comment_string_1032X;
+            SstackS = ((SstackS) + -4);
+            arg0K0 = 3;
+            goto L16665;}}
+        else {
+          goto L34561;}}
+      else {
+        goto L34561;}}
+    else {
+      goto L34561;}}
+  else {
+    goto L34561;}}
+ L30563: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = stob_877X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = proc_878X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 2;
+  goto L16665;}
+ L34107: {
+  minutesP_1043X = arg2K0;
+  if ((s48_Spending_interruptPS)) {
+    if ((s48_Spending_eventsPS)) {
+      s48_Spending_eventsPS = 0;
+      check_events_return_tag = 2;
+      goto check_events;
+     check_events_return_2:
+      temp_1044X = check_events0_return_value;
+      if (temp_1044X) {
+        goto L34133;}
+      else {
+        goto L34138;}}
+    else {
+      goto L34133;}}
+  else {
+    goto L34138;}}
+ L22847: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = proc_896X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = name_897X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 2;
+  goto L16665;}
+ L33368: {
+  key_1045X = arg0K0;
+  SstackS = ((SstackS) + 4);
+  arg2_1046X = *((long *) (SstackS));
+  if ((3 == (3 & arg2_1046X))) {
+    if ((16 == (31 & ((((*((long *) ((((char *) (-3 + arg2_1046X))) + -4))))>>2))))) {
+      x_1047X = SvalS;
+      if ((1 == x_1047X)) {
+        goto L33385;}
+      else {
+        if ((5 == x_1047X)) {
+          goto L33385;}
+        else {
+          goto L33390;}}}
+    else {
+      goto L33390;}}
+  else {
+    goto L33390;}}
+ L23938: {
+  table_1048X = arg0K0;
+  n_1049X = -1 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + arg2_686X))) + -4))))>>8));
+  arg0K0 = 0;
+  arg0K1 = 0;
+  goto L12880;}
+ L27369: {
+  len_1050X = 1 + n_907X;
+  addr_1051X = ALLOCATE_SPACE(16, (4 + len_1050X));
+  *((long *) addr_1051X) = (66 + (((len_1050X)<<8)));
+  string_1052X = 3 + (((long) (addr_1051X + 4)));
+  *((unsigned char *) ((((char *) (-3 + string_1052X))) + n_907X)) = 0;
+  arg0K0 = arg2_906X;
+  arg0K1 = (-1 + n_907X);
+  goto L27346;}
+ L27321: {
+  if ((25 == arg2_906X)) {
+    goto L27369;}
+  else {
+    push_exception_continuationB(5, 1);
+    *((long *) (SstackS)) = arg2_906X;
+    SstackS = ((SstackS) + -4);
+    *((long *) (SstackS)) = (((n_907X)<<2));
+    SstackS = ((SstackS) + -4);
+    arg0K0 = 2;
+    goto L16665;}}
+ L30968: {
+  if ((from_index_727X < 0)) {
+    goto L31022;}
+  else {
+    if ((to_index_728X < 0)) {
+      goto L31022;}
+    else {
+      if ((count_729X < 0)) {
+        goto L31022;}
+      else {
+        if ((3 == (3 & arg5_726X))) {
+          if ((16 == (31 & ((((*((long *) ((((char *) (-3 + arg5_726X))) + -4))))>>2))))) {
+            arg0K0 = (-1 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + arg5_726X))) + -4))))>>8)));
+            goto L30989;}
+          else {
+            goto L30985;}}
+        else {
+          goto L30985;}}}}}
+ L30963: {
+  if ((3 == (3 & arg5_726X))) {
+    if ((17 == (31 & ((((*((long *) ((((char *) (-3 + arg5_726X))) + -4))))>>2))))) {
+      goto L30968;}
+    else {
+      goto L31022;}}
+  else {
+    goto L31022;}}
+ L31022: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = arg5_726X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((from_index_727X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = arg3_724X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((to_index_728X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((count_729X)<<2));
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 5;
+  goto L16665;}
+ L23097: {
+  push_exception_continuationB(5, 2);
+  *((long *) (SstackS)) = port_913X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 1;
+  goto L16665;}
+ L23077: {
+  push_exception_continuationB(14, 2);
+  *((long *) (SstackS)) = port_913X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 1;
+  goto L16665;}
+ L23317: {
+  push_exception_continuationB(5, 2);
+  *((long *) (SstackS)) = port_921X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 1;
+  goto L16665;}
+ L23297: {
+  push_exception_continuationB(14, 2);
+  *((long *) (SstackS)) = port_921X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 1;
+  goto L16665;}
+ L23531: {
+  push_exception_continuationB(5, 2);
+  *((long *) (SstackS)) = Kchar_927X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = port_928X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 2;
+  goto L16665;}
+ L23513: {
+  push_exception_continuationB(14, 2);
+  *((long *) (SstackS)) = Kchar_927X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = port_928X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 2;
+  goto L16665;}
+ L29458: {
+  arg0K0 = (*((long *) ((((char *) (-3 + stuff_935X))) + 4)));
+  goto L29452;}
+ L11650: {
+  if ((3 == (3 & thing_936X))) {
+    if ((16 == (31 & ((((*((long *) ((((char *) (-3 + thing_936X))) + -4))))>>2))))) {
+      arg3K0 = (((char *)(((char *) (-3 + thing_936X)))));
+      goto L11692;}
+    else {
+      goto L11658;}}
+  else {
+    goto L11658;}}
+ L29443: {
+  { long ignoreXX;
+  PS_WRITE_CHAR(10, out_738X, ignoreXX) }
+  SvalS = 13;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L16741: {
+  StemplateS = (SvalS);
+  Slosing_opcodeS = opcode_740X;
+  arg0K0 = (2 + nargs_739X);
+  goto L16066;}
+ L16811: {
+  merged_arg3K0 = "exception handler is not a closure";
+  loseD0_return_tag = 1;
+  goto loseD0;
+ loseD0_return_1:
+  goto L16741;}
+ L20966: {
+  key_1053X = arg0K0;
+  p_1054X = SenvS;
+  if ((3 == (3 & p_1054X))) {
+    if ((p_1054X < (((long) (Sstack_beginS))))) {
+      goto L21061;}
+    else {
+      if (((((long) (Sstack_endS))) < p_1054X)) {
+        goto L21061;}
+      else {
+        merged_arg0K0 = (SenvS);
+        merged_arg0K1 = (ScontS);
+        merged_arg0K2 = key_1053X;
+        merged_arg0K3 = 0;
+        save_env_in_heap_return_tag = 0;
+        goto save_env_in_heap;
+       save_env_in_heap_return_0:
+        v_1055X = save_env_in_heap0_return_value;
+        SenvS = v_1055X;
+        goto L21061;}}}
+  else {
+    goto L21061;}}
+ L20977: {
+  env_1056X = arg0K0;
+  a_1057X = *((long *) ((((char *) (-3 + (StemplateS)))) + ((((((((*((unsigned char *) ((Scode_pointerS) + 1))))<<8)) + (*((unsigned char *) ((Scode_pointerS) + 2)))))<<2))));
+  addr_1058X = ALLOCATE_SPACE(3, 12);
+  *((long *) addr_1058X) = 2062;
+  x_1059X = 3 + (((long) (addr_1058X + 4)));
+  *((long *) (((char *) (-3 + x_1059X)))) = a_1057X;
+  *((long *) ((((char *) (-3 + x_1059X))) + 4)) = env_1056X;
+  if ((3 == (3 & x_1059X))) {
+    if ((0 == (128 & (*((long *) ((((char *) (-3 + x_1059X))) + -4)))))) {
+      *((long *) ((((char *) (-3 + x_1059X))) + -4)) = (128 | (*((long *) ((((char *) (-3 + x_1059X))) + -4))));
+      arg0K0 = x_1059X;
+      goto L20985;}
+    else {
+      arg0K0 = x_1059X;
+      goto L20985;}}
+  else {
+    arg0K0 = x_1059X;
+    goto L20985;}}
+ L20788: {
+  i_1060X = arg0K0;
+  offset_1061X = arg0K1;
+  env_1062X = arg0K2;
+  if ((i_1060X == total_count_393X)) {
+    SvalS = new_env_762X;
+    Scode_pointerS = ((Scode_pointerS) + (1 + offset_1061X));
+    arg1K0 = (Scode_pointerS);
+    goto L18438;}
+  else {
+    back_1063X = *((unsigned char *) ((Scode_pointerS) + (1 + offset_1061X)));
+    arg0K0 = env_1062X;
+    arg0K1 = back_1063X;
+    goto L20884;}}
+ L20684: {
+  value_1064X = arg0K0;
+  SvalS = value_1064X;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L16999: {
+  i_1065X = arg0K0;
+  m_1066X = arg0K1;
+  if ((0 == (n_950X & m_1066X))) {
+    arg0K0 = (1 + i_1065X);
+    arg0K1 = (((m_1066X)<<1));
+    goto L16999;}
+  else {
+    Spending_interruptsS = ((Spending_interruptsS) & (~ m_1066X));
+    if ((i_1065X == 0)) {
+      *((long *) (SstackS)) = (Sinterrupted_templateS);
+      SstackS = ((SstackS) + -4);
+      Sinterrupted_templateS = 1;
+      *((long *) (SstackS)) = ((((Senabled_interruptsS))<<2));
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 2;
+      goto L16918;}
+    else {
+      if ((i_1065X == 2)) {
+        *((long *) (SstackS)) = (Sfinalize_theseS);
+        SstackS = ((SstackS) + -4);
+        Sfinalize_theseS = 25;
+        *((long *) (SstackS)) = ((((Senabled_interruptsS))<<2));
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16918;}
+      else {
+        if ((i_1065X == 3)) {
+          channel_1067X = Spending_channels_headS;
+          next_1068X = *((long *) ((((char *) (-3 + channel_1067X))) + 12));
+          Spending_channels_headS = next_1068X;
+          addr_1069X = (((char *) (-3 + channel_1067X))) + 12;
+          S48_WRITE_BARRIER(channel_1067X, addr_1069X, 1);
+          *((long *) addr_1069X) = 1;
+          if ((1 == next_1068X)) {
+            Spending_channels_tailS = 1;
+            arg0K0 = channel_1067X;
+            goto L8364;}
+          else {
+            arg0K0 = channel_1067X;
+            goto L8364;}}
+        else {
+          if ((i_1065X == 4)) {
+            *((long *) (SstackS)) = (Sos_signal_typeS);
+            SstackS = ((SstackS) + -4);
+            *((long *) (SstackS)) = (Sos_signal_argumentS);
+            SstackS = ((SstackS) + -4);
+            Sos_signal_typeS = 1;
+            Sos_signal_argumentS = 1;
+            *((long *) (SstackS)) = ((((Senabled_interruptsS))<<2));
+            SstackS = ((SstackS) + -4);
+            arg0K0 = 3;
+            goto L16918;}
+          else {
+            *((long *) (SstackS)) = ((((Senabled_interruptsS))<<2));
+            SstackS = ((SstackS) + -4);
+            arg0K0 = 1;
+            goto L16918;}}}}}}
+ L16084: {
+  skip_1070X = arg0K0;
+  stack_arg_count_1071X = arg0K1;
+  template_1072X = *((long *) (((char *) (-3 + (SvalS)))));
+  StemplateS = template_1072X;
+  Scode_pointerS = ((((char *) (-3 + (*((long *) (((char *) (-3 + template_1072X)))))))) + skip_1070X);
+  SenvS = (*((long *) ((((char *) (-3 + (SvalS)))) + 4)));
+  arg0K0 = stack_space_952X;
+  arg0K1 = stack_arg_count_1071X;
+  goto L15974;}
+ L16107: {
+  skip_1073X = arg0K0;
+  *((long *) (SstackS)) = 25;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((stack_arg_count_771X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((stack_arg_count_771X)<<2));
+  SstackS = ((SstackS) + -4);
+  arg0K0 = skip_1073X;
+  arg0K1 = (3 + stack_arg_count_771X);
+  goto L16084;}
+ L16361: {
+  skip_1074X = arg0K0;
+  stack_arg_count_1075X = arg0K1;
+  template_1076X = *((long *) (((char *) (-3 + (SvalS)))));
+  StemplateS = template_1076X;
+  Scode_pointerS = ((((char *) (-3 + (*((long *) (((char *) (-3 + template_1076X)))))))) + skip_1074X);
+  SenvS = (*((long *) ((((char *) (-3 + (SvalS)))) + 4)));
+  arg0K0 = stack_space_959X;
+  arg0K1 = stack_arg_count_1075X;
+  goto L15974;}
+ L16386: {
+  skip_1077X = arg0K0;
+  if ((total_arg_count_790X < 3)) {
+    arg0K0 = total_arg_count_790X;
+    goto L16394;}
+  else {
+    if ((2 < stack_arg_count_784X)) {
+      arg0K0 = stack_arg_count_784X;
+      goto L16394;}
+    else {
+      arg0K0 = 2;
+      goto L16394;}}}
+ L19282: {
+  SvalS = (*((long *) ((((char *) (-3 + cont_965X))) + 16)));
+  arg0K0 = stack_nargs_801X;
+  arg0K1 = list_args_802X;
+  arg0K2 = list_arg_count_803X;
+  goto L17666;}
+ L20444: {
+  merged_arg0K0 = list_args_802X;
+  merged_arg0K1 = stack_nargs_801X;
+  pop_args_GlistS_return_tag = 4;
+  goto pop_args_GlistS;
+ pop_args_GlistS_return_4:
+  args_1078X = pop_args_GlistS0_return_value;
+  push_exception_continuationB(4, 0);
+  *((long *) (SstackS)) = 1;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = args_1078X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 2;
+  goto L16665;}
+ L10634: {
+  if ((3 == (3 & x_456X))) {
+    if ((10 == (31 & ((((*((long *) ((((char *) (-3 + x_456X))) + -4))))>>2))))) {
+      arg0K0 = 5;
+      goto L38038;}
+    else {
+      arg0K0 = 1;
+      goto L38038;}}
+  else {
+    arg0K0 = 1;
+    goto L38038;}}
+ L28549: {
+  if ((3 == (3 & n_458X))) {
+    if ((10 == (31 & ((((*((long *) ((((char *) (-3 + n_458X))) + -4))))>>2))))) {
+      push_exception_continuationB(5, 1);
+      *((long *) (SstackS)) = n_458X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 1;
+      goto L16665;}
+    else {
+      goto L28553;}}
+  else {
+    goto L28553;}}
+ L28748: {
+  if ((3 == (3 & n_459X))) {
+    if ((10 == (31 & ((((*((long *) ((((char *) (-3 + n_459X))) + -4))))>>2))))) {
+      push_exception_continuationB(5, 1);
+      *((long *) (SstackS)) = n_459X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 1;
+      goto L16665;}
+    else {
+      goto L28752;}}
+  else {
+    goto L28752;}}
+ L28947: {
+  if ((3 == (3 & n_460X))) {
+    if ((10 == (31 & ((((*((long *) ((((char *) (-3 + n_460X))) + -4))))>>2))))) {
+      push_exception_continuationB(5, 1);
+      *((long *) (SstackS)) = n_460X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 1;
+      goto L16665;}
+    else {
+      goto L28951;}}
+  else {
+    goto L28951;}}
+ L6821: {
+  if ((536870911 < lo_c_976X)) {
+    push_exception_continuationB(5, 1);
+    *((long *) (SstackS)) = arg2_467X;
+    SstackS = ((SstackS) + -4);
+    *((long *) (SstackS)) = x_468X;
+    SstackS = ((SstackS) + -4);
+    arg0K0 = 2;
+    goto L16665;}
+  else {
+    if ((lo_c_976X < 0)) {
+      push_exception_continuationB(5, 1);
+      *((long *) (SstackS)) = arg2_467X;
+      SstackS = ((SstackS) + -4);
+      *((long *) (SstackS)) = x_468X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 2;
+      goto L16665;}
+    else {
+      if ((8192 < mid_c_979X)) {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = arg2_467X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = x_468X;
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}
+      else {
+        if ((a_469X < 0)) {
+          if ((b_470X < 0)) {
+            goto L6848;}
+          else {
+            goto L6855;}}
+        else {
+          if ((b_470X < 0)) {
+            goto L6855;}
+          else {
+            goto L6848;}}}}}}
+ L7115: {
+  if ((536870911 < c_982X)) {
+    push_exception_continuationB(5, 1);
+    *((long *) (SstackS)) = arg2_474X;
+    SstackS = ((SstackS) + -4);
+    *((long *) (SstackS)) = x_475X;
+    SstackS = ((SstackS) + -4);
+    arg0K0 = 2;
+    goto L16665;}
+  else {
+    SvalS = (((c_982X)<<2));
+    Scode_pointerS = ((Scode_pointerS) + 1);
+    arg1K0 = (Scode_pointerS);
+    goto L18438;}}
+ L7114: {
+  SvalS = ((((0 - c_982X))<<2));
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L7283: {
+  if ((536870911 < c_985X)) {
+    push_exception_continuationB(5, 1);
+    *((long *) (SstackS)) = arg2_488X;
+    SstackS = ((SstackS) + -4);
+    *((long *) (SstackS)) = x_489X;
+    SstackS = ((SstackS) + -4);
+    arg0K0 = 2;
+    goto L16665;}
+  else {
+    SvalS = (((c_985X)<<2));
+    Scode_pointerS = ((Scode_pointerS) + 1);
+    arg1K0 = (Scode_pointerS);
+    goto L18438;}}
+ L7282: {
+  SvalS = ((((0 - c_985X))<<2));
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L25344: {
+  n_1079X = arg0K0;
+  SvalS = (((n_1079X)<<2));
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L21523: {
+  i_1080X = arg0K0;
+  rest_list_1081X = arg0K1;
+  if ((25 == rest_list_1081X)) {
+    SvalS = new_838X;
+    Scode_pointerS = ((Scode_pointerS) + 2);
+    arg1K0 = (Scode_pointerS);
+    goto L18438;}
+  else {
+    *((long *) ((((char *) (-3 + new_838X))) + (((i_1080X)<<2)))) = (*((long *) (((char *) (-3 + rest_list_1081X)))));
+    arg0K0 = (1 + i_1080X);
+    arg0K1 = (*((long *) ((((char *) (-3 + rest_list_1081X))) + 4)));
+    goto L21523;}}
+ L13301: {
+  foo_1082X = arg0K0;
+  if ((1 == foo_1082X)) {
+    addr_1083X = ALLOCATE_SPACE(1, 12);
+    *((long *) addr_1083X) = 2054;
+    x_1084X = 3 + (((long) (addr_1083X + 4)));
+    *((long *) (((char *) (-3 + x_1084X)))) = string_853X;
+    *((long *) ((((char *) (-3 + x_1084X))) + 4)) = bucket_997X;
+    addr_1085X = (((char *) (-3 + table_852X))) + (((index_996X)<<2));
+    S48_WRITE_BARRIER(table_852X, addr_1085X, x_1084X);
+    *((long *) addr_1085X) = x_1084X;
+    arg0K0 = x_1084X;
+    goto L24529;}
+  else {
+    s2_1086X = *((long *) (((char *) (-3 + foo_1082X))));
+    len_1087X = (long)(((unsigned long)(*((long *) ((((char *) (-3 + string_853X))) + -4))))>>8);
+    if ((len_1087X == ((long)(((unsigned long)(*((long *) ((((char *) (-3 + s2_1086X))) + -4))))>>8)))) {
+      if (((!memcmp((void *)(((char *) (-3 + s2_1086X))), (void *)(((char *) (-3 + string_853X))),len_1087X)))) {
+        arg0K0 = foo_1082X;
+        goto L24529;}
+      else {
+        goto L13317;}}
+    else {
+      goto L13317;}}}
+ L26773: {
+  if ((0 == (3 & arg2_999X))) {
+    if (((((arg2_999X)>>2)) < 0)) {
+      push_exception_continuationB(5, 1);
+      *((long *) (SstackS)) = arg2_999X;
+      SstackS = ((SstackS) + -4);
+      *((long *) (SstackS)) = (((mode_1000X)<<2));
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 2;
+      goto L16665;}
+    else {
+      arg0K0 = (((arg2_999X)>>2));
+      goto L26593;}}
+  else {
+    if ((3 == (3 & arg2_999X))) {
+      if ((16 == (31 & ((((*((long *) ((((char *) (-3 + arg2_999X))) + -4))))>>2))))) {
+        if ((1 == mode_1000X)) {
+          goto L26651;}
+        else {
+          if ((3 == mode_1000X)) {
+            goto L26651;}
+          else {
+            v_1088X = ps_open_fd((((char *)(((char *) (-3 + arg2_999X))))), 0, &v_1089X);
+            arg0K0 = v_1088X;
+            arg0K1 = v_1089X;
+            goto L26664;}}}
+      else {
+        push_exception_continuationB(5, 1);
+        *((long *) (SstackS)) = arg2_999X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = (((mode_1000X)<<2));
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+    else {
+      push_exception_continuationB(5, 1);
+      *((long *) (SstackS)) = arg2_999X;
+      SstackS = ((SstackS) + -4);
+      *((long *) (SstackS)) = (((mode_1000X)<<2));
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 2;
+      goto L16665;}}}
+ L34464: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 1;
+  goto L16665;}
+ L37305: {
+  obj_1090X = SvalS;
+  if ((3 == (3 & obj_1090X))) {
+    if ((5 == (31 & ((((*((long *) ((((char *) (-3 + obj_1090X))) + -4))))>>2))))) {
+      x_1091X = SvalS;
+      if ((1 == arg2_1007X)) {
+        arg2K0 = 0;
+        goto L37322;}
+      else {
+        arg2K0 = 1;
+        goto L37322;}}
+    else {
+      goto L37325;}}
+  else {
+    goto L37325;}}
+ L37325: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = arg5_1010X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = arg4_1009X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = arg3_1008X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = arg2_1007X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 5;
+  goto L16665;}
+ L36856: {
+  if ((3 == (3 & arg4_1014X))) {
+    if ((16 == (31 & ((((*((long *) ((((char *) (-3 + arg4_1014X))) + -4))))>>2))))) {
+      arg0K0 = (-1 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + arg4_1014X))) + -4))))>>8)));
+      goto L36868;}
+    else {
+      goto L36864;}}
+  else {
+    goto L36864;}}
+ L36848: {
+  if ((3 == (3 & arg4_1014X))) {
+    if ((17 == (31 & ((((*((long *) ((((char *) (-3 + arg4_1014X))) + -4))))>>2))))) {
+      goto L36856;}
+    else {
+      arg0K0 = 5;
+      goto L36739;}}
+  else {
+    arg0K0 = 5;
+    goto L36739;}}
+ L36739: {
+  reason_1092X = arg0K0;
+  push_exception_continuationB(reason_1092X, 1);
+  *((long *) (SstackS)) = arg4_1014X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((start_1016X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((count_1017X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = channel_1018X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 4;
+  goto L16665;}
+ L37587: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = arg4_1014X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = arg3_1013X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = arg2_1012X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 4;
+  goto L16665;}
+ L14798: {
+  v_1093X = arg0K0;
+  arg0K0 = (-1 + i_1023X);
+  arg0K1 = v_1093X;
+  goto L14784;}
+ L30184: {
+  reason_1094X = arg0K0;
+  status_1095X = arg0K1;
+  push_exception_continuationB(reason_1094X, 1);
+  *((long *) (SstackS)) = arg3_1030X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = arg2_1029X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = comment_string_1032X;
+  SstackS = ((SstackS) + -4);
+  merged_arg0K0 = status_1095X;
+  merged_arg0K1 = key_1028X;
+  get_error_string_return_tag = 1;
+  goto get_error_string;
+ get_error_string_return_1:
+  x_1096X = get_error_string0_return_value;
+  *((long *) (SstackS)) = x_1096X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 4;
+  goto L16665;}
+ L34561: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = arg3_1030X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = arg2_1029X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 3;
+  goto L16665;}
+ L34133: {
+  SvalS = 13;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L34138: {
+  if ((0 == (Spending_interruptsS))) {
+    s48_wait_for_event((((arg2_678X)>>2)), minutesP_1043X);
+    goto L34133;}
+  else {
+    goto L34133;}}
+ L33385: {
+  if ((1 == (SvalS))) {
+    v_1097X = Hlookup2102((Sexported_bindingsS), arg2_1046X, key_1045X);
+    arg0K0 = v_1097X;
+    goto L33442;}
+  else {
+    v_1098X = Hlookup2083((Simported_bindingsS), arg2_1046X, key_1045X);
+    arg0K0 = v_1098X;
+    goto L33442;}}
+ L33390: {
+  push_exception_continuationB(5, 1);
+  *((long *) (SstackS)) = arg2_1046X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (SvalS);
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 2;
+  goto L16665;}
+ L12880: {
+  i_1099X = arg0K0;
+  h_1100X = arg0K1;
+  if ((i_1099X < n_1049X)) {
+    arg0K0 = (1 + i_1099X);
+    arg0K1 = (h_1100X + (((*((unsigned char *) ((((char *) (-3 + arg2_686X))) + i_1099X))))));
+    goto L12880;}
+  else {
+    index_1101X = 1023 & h_1100X;
+    bucket_1102X = *((long *) ((((char *) (-3 + table_1048X))) + (((index_1101X)<<2))));
+    arg0K0 = 1;
+    arg0K1 = bucket_1102X;
+    goto L12844;}}
+ L27346: {
+  l_1103X = arg0K0;
+  i_1104X = arg0K1;
+  if ((i_1104X < 0)) {
+    SvalS = string_1052X;
+    Scode_pointerS = ((Scode_pointerS) + 1);
+    arg1K0 = (Scode_pointerS);
+    goto L18438;}
+  else {
+    *((unsigned char *) ((((char *) (-3 + string_1052X))) + i_1104X)) = ((((((*((long *) (((char *) (-3 + l_1103X))))))>>8))));
+    arg0K0 = (*((long *) ((((char *) (-3 + l_1103X))) + 4)));
+    arg0K1 = (-1 + i_1104X);
+    goto L27346;}}
+ L30989: {
+  y_1105X = arg0K0;
+  if ((y_1105X < (from_index_727X + count_729X))) {
+    goto L31022;}
+  else {
+    if ((3 == (3 & arg3_724X))) {
+      if ((16 == (31 & ((((*((long *) ((((char *) (-3 + arg3_724X))) + -4))))>>2))))) {
+        arg0K0 = (-1 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + arg3_724X))) + -4))))>>8)));
+        goto L31004;}
+      else {
+        goto L31000;}}
+    else {
+      goto L31000;}}}
+ L30985: {
+  arg0K0 = ((long)(((unsigned long)(*((long *) ((((char *) (-3 + arg5_726X))) + -4))))>>8));
+  goto L30989;}
+ L11692: {
+  v_1106X = arg3K0;
+  ps_write_string(v_1106X, out_738X);
+  goto L29458;}
+ L11658: {
+  if ((3 == (3 & thing_936X))) {
+    if ((1 == (31 & ((((*((long *) ((((char *) (-3 + thing_936X))) + -4))))>>2))))) {
+      arg3K0 = (((char *)(((char *) (-3 + (*((long *) (((char *) (-3 + thing_936X))))))))));
+      goto L11692;}
+    else {
+      goto L11666;}}
+  else {
+    goto L11666;}}
+ L21061: {
+  arg0K0 = (SenvS);
+  goto L20971;}
+ L20985: {
+  value_1107X = arg0K0;
+  SvalS = value_1107X;
+  Scode_pointerS = ((Scode_pointerS) + 4);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L20884: {
+  env_1108X = arg0K0;
+  i_1109X = arg0K1;
+  if ((0 == i_1109X)) {
+    count_1110X = *((unsigned char *) ((Scode_pointerS) + (2 + offset_1061X)));
+    arg0K0 = count_1110X;
+    arg0K1 = i_1060X;
+    arg0K2 = (2 + offset_1061X);
+    goto L20805;}
+  else {
+    arg0K0 = (*((long *) (((char *) (-3 + env_1108X)))));
+    arg0K1 = (-1 + i_1109X);
+    goto L20884;}}
+ L16918: {
+  arg_count_1111X = arg0K0;
+  obj_1112X = Sinterrupt_handlersS;
+  if ((3 == (3 & obj_1112X))) {
+    if ((2 == (31 & ((((*((long *) ((((char *) (-3 + obj_1112X))) + -4))))>>2))))) {
+      goto L16932;}
+    else {
+      goto L17012;}}
+  else {
+    goto L17012;}}
+ L8364: {
+  channel_1113X = arg0K0;
+  x_1114X = 1 == (Spending_channels_headS);
+  if (x_1114X) {
+    goto L8378;}
+  else {
+    Spending_interruptsS = (8 | (Spending_interruptsS));
+    if ((0 == ((Spending_interruptsS) & (Senabled_interruptsS)))) {
+      s48_Spending_interruptPS = 0;
+      if ((s48_Spending_eventsPS)) {
+        s48_Spending_interruptPS = 1;
+        goto L8378;}
+      else {
+        goto L8378;}}
+    else {
+      s48_Spending_interruptPS = 1;
+      goto L8378;}}}
+ L15974: {
+  stack_slots_1115X = arg0K0;
+  stack_arg_count_1116X = arg0K1;
+  if ((stack_slots_1115X < (64 + (((((SstackS) - (Sstack_limitS)))>>2))))) {
+    goto L15976;}
+  else {
+    space_1117X = 1 + (((((Sstack_endS) - (SstackS)))>>2));
+    v_1118X = AVAILABLEp(space_1117X);
+    if (v_1118X) {
+      arg2K0 = 1;
+      arg0K1 = 0;
+      goto L16033;}
+    else {
+      collect_saving_temps(1, 1, &temp1_1119X);
+      v_1120X = AVAILABLEp(space_1117X);
+      if (v_1120X) {
+        arg2K0 = 1;
+        arg0K1 = 0;
+        goto L16033;}
+      else {
+        arg2K0 = 0;
+        arg0K1 = 0;
+        goto L16033;}}}}
+ L16394: {
+  final_stack_arg_count_1121X = arg0K0;
+  if ((stack_arg_count_784X < final_stack_arg_count_1121X)) {
+    arg0K0 = final_stack_arg_count_1121X;
+    goto L16398;}
+  else {
+    arg0K0 = stack_arg_count_784X;
+    goto L16398;}}
+ L28553: {
+  SvalS = 1;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L28752: {
+  SvalS = 1;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L28951: {
+  SvalS = 1;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L6848: {
+  if ((536870911 < c_980X)) {
+    push_exception_continuationB(5, 1);
+    *((long *) (SstackS)) = arg2_467X;
+    SstackS = ((SstackS) + -4);
+    *((long *) (SstackS)) = x_468X;
+    SstackS = ((SstackS) + -4);
+    arg0K0 = 2;
+    goto L16665;}
+  else {
+    SvalS = (((c_980X)<<2));
+    Scode_pointerS = ((Scode_pointerS) + 1);
+    arg1K0 = (Scode_pointerS);
+    goto L18438;}}
+ L6855: {
+  if ((536870912 < c_980X)) {
+    push_exception_continuationB(5, 1);
+    *((long *) (SstackS)) = arg2_467X;
+    SstackS = ((SstackS) + -4);
+    *((long *) (SstackS)) = x_468X;
+    SstackS = ((SstackS) + -4);
+    arg0K0 = 2;
+    goto L16665;}
+  else {
+    SvalS = ((((0 - c_980X))<<2));
+    Scode_pointerS = ((Scode_pointerS) + 1);
+    arg1K0 = (Scode_pointerS);
+    goto L18438;}}
+ L24529: {
+  val_1122X = arg0K0;
+  SvalS = val_1122X;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L13317: {
+  arg0K0 = (*((long *) ((((char *) (-3 + foo_1082X))) + 4)));
+  goto L13301;}
+ L26593: {
+  index_1123X = arg0K0;
+  channel_1124X = make_registered_channel(mode_1000X, arg2_999X, index_1123X, key_998X, &reason_1125X);
+  if ((1 == channel_1124X)) {
+    if ((3 == (3 & arg2_999X))) {
+      if ((16 == (31 & ((((*((long *) ((((char *) (-3 + arg2_999X))) + -4))))>>2))))) {
+        if ((1 == mode_1000X)) {
+          goto L26708;}
+        else {
+          if ((3 == mode_1000X)) {
+            goto L26708;}
+          else {
+            v_1126X = ps_close_fd(index_1123X);
+            arg0K0 = v_1126X;
+            goto L26703;}}}
+      else {
+        push_exception_continuationB(reason_1125X, 1);
+        *((long *) (SstackS)) = arg2_999X;
+        SstackS = ((SstackS) + -4);
+        *((long *) (SstackS)) = (((mode_1000X)<<2));
+        SstackS = ((SstackS) + -4);
+        arg0K0 = 2;
+        goto L16665;}}
+    else {
+      push_exception_continuationB(reason_1125X, 1);
+      *((long *) (SstackS)) = arg2_999X;
+      SstackS = ((SstackS) + -4);
+      *((long *) (SstackS)) = (((mode_1000X)<<2));
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 2;
+      goto L16665;}}
+  else {
+    SvalS = channel_1124X;
+    Scode_pointerS = ((Scode_pointerS) + 1);
+    arg1K0 = (Scode_pointerS);
+    goto L18438;}}
+ L26651: {
+  v_1127X = ps_open_fd((((char *)(((char *) (-3 + arg2_999X))))), 1, &v_1128X);
+  arg0K0 = v_1127X;
+  arg0K1 = v_1128X;
+  goto L26664;}
+ L26664: {
+  channel_1129X = arg0K0;
+  status_1130X = arg0K1;
+  if ((status_1130X == NO_ERRORS)) {
+    arg0K0 = channel_1129X;
+    goto L26593;}
+  else {
+    if ((status_1130X == ENOENT)) {
+      push_exception_continuationB(10, 1);
+      *((long *) (SstackS)) = arg2_999X;
+      SstackS = ((SstackS) + -4);
+      *((long *) (SstackS)) = (((mode_1000X)<<2));
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 2;
+      goto L16665;}
+    else {
+      push_exception_continuationB(25, 1);
+      *((long *) (SstackS)) = arg2_999X;
+      SstackS = ((SstackS) + -4);
+      *((long *) (SstackS)) = (((mode_1000X)<<2));
+      SstackS = ((SstackS) + -4);
+      merged_arg0K0 = status_1130X;
+      merged_arg0K1 = key_998X;
+      get_error_string_return_tag = 2;
+      goto get_error_string;
+     get_error_string_return_2:
+      x_1131X = get_error_string0_return_value;
+      *((long *) (SstackS)) = x_1131X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 3;
+      goto L16665;}}}
+ L37322: {
+  waitP_1132X = arg2K0;
+  start_1133X = ((arg4_1009X)>>2);
+  count_1134X = ((arg3_1008X)>>2);
+  if ((4 == (*((long *) (((char *) (-3 + x_1091X))))))) {
+    if ((3 == (3 & arg5_1010X))) {
+      if ((0 == (128 & (*((long *) ((((char *) (-3 + arg5_1010X))) + -4)))))) {
+        if ((3 == (3 & arg5_1010X))) {
+          if ((16 == (31 & ((((*((long *) ((((char *) (-3 + arg5_1010X))) + -4))))>>2))))) {
+            goto L36458;}
+          else {
+            goto L36450;}}
+        else {
+          goto L36450;}}
+      else {
+        arg0K0 = 5;
+        goto L36341;}}
+    else {
+      arg0K0 = 5;
+      goto L36341;}}
+  else {
+    arg0K0 = 5;
+    goto L36341;}}
+ L36868: {
+  length_1135X = arg0K0;
+  if ((length_1135X < (start_1016X + count_1017X))) {
+    arg0K0 = 7;
+    goto L36739;}
+  else {
+    got_1136X = ps_write_fd(((((*((long *) ((((char *) (-3 + channel_1018X))) + 8))))>>2)), ((((char *) (-3 + arg4_1014X))) + start_1016X), count_1017X, &pendingP_1137X, &status_1138X);
+    if ((status_1138X == NO_ERRORS)) {
+      if (pendingP_1137X) {
+        addr_1139X = (((char *) (-3 + channel_1018X))) + 16;
+        S48_WRITE_BARRIER(channel_1018X, addr_1139X, 5);
+        *((long *) addr_1139X) = 5;
+        s48_Spending_interruptPS = 0;
+        Senabled_interruptsS = 0;
+        arg0K0 = 13;
+        goto L36739;}
+      else {
+        SvalS = (((got_1136X)<<2));
+        Scode_pointerS = ((Scode_pointerS) + 1);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}}
+    else {
+      push_exception_continuationB(25, 1);
+      *((long *) (SstackS)) = arg4_1014X;
+      SstackS = ((SstackS) + -4);
+      *((long *) (SstackS)) = (((start_1016X)<<2));
+      SstackS = ((SstackS) + -4);
+      *((long *) (SstackS)) = (((count_1017X)<<2));
+      SstackS = ((SstackS) + -4);
+      *((long *) (SstackS)) = channel_1018X;
+      SstackS = ((SstackS) + -4);
+      merged_arg0K0 = status_1138X;
+      merged_arg0K1 = key_1011X;
+      get_error_string_return_tag = 3;
+      goto get_error_string;
+     get_error_string_return_3:
+      x_1140X = get_error_string0_return_value;
+      *((long *) (SstackS)) = x_1140X;
+      SstackS = ((SstackS) + -4);
+      arg0K0 = 5;
+      goto L16665;}}}
+ L36864: {
+  arg0K0 = ((long)(((unsigned long)(*((long *) ((((char *) (-3 + arg4_1014X))) + -4))))>>8));
+  goto L36868;}
+ L33442: {
+  val_1141X = arg0K0;
+  SvalS = val_1141X;
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L12844: {
+  previous_foo_1142X = arg0K0;
+  foo_1143X = arg0K1;
+  if ((1 == foo_1143X)) {
+    goto L23940;}
+  else {
+    s2_1144X = *((long *) (((char *) (-3 + foo_1143X))));
+    len_1145X = (long)(((unsigned long)(*((long *) ((((char *) (-3 + arg2_686X))) + -4))))>>8);
+    if ((len_1145X == ((long)(((unsigned long)(*((long *) ((((char *) (-3 + s2_1144X))) + -4))))>>8)))) {
+      if (((!memcmp((void *)(((char *) (-3 + s2_1144X))), (void *)(((char *) (-3 + arg2_686X))),len_1145X)))) {
+        if ((1 == previous_foo_1142X)) {
+          value_1146X = *((long *) ((((char *) (-3 + foo_1143X))) + 12));
+          addr_1147X = (((char *) (-3 + table_1048X))) + (((index_1101X)<<2));
+          S48_WRITE_BARRIER(table_1048X, addr_1147X, value_1146X);
+          *((long *) addr_1147X) = value_1146X;
+          goto L23940;}
+        else {
+          val_1148X = *((long *) ((((char *) (-3 + foo_1143X))) + 12));
+          addr_1149X = (((char *) (-3 + previous_foo_1142X))) + 12;
+          S48_WRITE_BARRIER(previous_foo_1142X, addr_1149X, val_1148X);
+          *((long *) addr_1149X) = val_1148X;
+          goto L23940;}}
+      else {
+        goto L12906;}}
+    else {
+      goto L12906;}}}
+ L31004: {
+  y_1150X = arg0K0;
+  if ((y_1150X < (to_index_728X + count_729X))) {
+    goto L31022;}
+  else {
+    memcpy((void *)((((char *) (-3 + arg3_724X))) + to_index_728X), (void *)((((char *) (-3 + arg5_726X))) + from_index_727X),count_729X);
+    SvalS = 13;
+    Scode_pointerS = ((Scode_pointerS) + 1);
+    arg1K0 = (Scode_pointerS);
+    goto L18438;}}
+ L31000: {
+  arg0K0 = ((long)(((unsigned long)(*((long *) ((((char *) (-3 + arg3_724X))) + -4))))>>8));
+  goto L31004;}
+ L11666: {
+  if ((1 == thing_936X)) {
+    goto L11669;}
+  else {
+    if ((5 == thing_936X)) {
+      goto L11669;}
+    else {
+      if ((25 == thing_936X)) {
+        arg3K0 = "()";
+        goto L11692;}
+      else {
+        if ((3 == (3 & thing_936X))) {
+          if ((0 == (31 & ((((*((long *) ((((char *) (-3 + thing_936X))) + -4))))>>2))))) {
+            arg3K0 = "(...)";
+            goto L11692;}
+          else {
+            goto L11682;}}
+        else {
+          goto L11682;}}}}}
+ L20805: {
+  count_1151X = arg0K0;
+  i_1152X = arg0K1;
+  offset_1153X = arg0K2;
+  if ((0 == count_1151X)) {
+    arg0K0 = i_1152X;
+    arg0K1 = offset_1153X;
+    arg0K2 = env_1108X;
+    goto L20788;}
+  else {
+    value_1154X = *((long *) ((((char *) (-3 + env_1108X))) + ((((*((unsigned char *) ((Scode_pointerS) + (1 + offset_1153X)))))<<2))));
+    addr_1155X = (((char *) (-3 + new_env_762X))) + (((i_1152X)<<2));
+    S48_WRITE_BARRIER(new_env_762X, addr_1155X, value_1154X);
+    *((long *) addr_1155X) = value_1154X;
+    arg0K0 = (-1 + count_1151X);
+    arg0K1 = (1 + i_1152X);
+    arg0K2 = (1 + offset_1153X);
+    goto L20805;}}
+ L16932: {
+  Senabled_interruptsS = 0;
+  if ((0 == ((Spending_interruptsS) & (Senabled_interruptsS)))) {
+    s48_Spending_interruptPS = 0;
+    if ((s48_Spending_eventsPS)) {
+      s48_Spending_interruptPS = 1;
+      goto L16934;}
+    else {
+      goto L16934;}}
+  else {
+    s48_Spending_interruptPS = 1;
+    goto L16934;}}
+ L17012: {
+  ps_error("interrupt handler is not a vector", 0);
+  goto L16932;}
+ L8378: {
+  *((long *) (SstackS)) = channel_1113X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (*((long *) ((((char *) (-3 + channel_1113X))) + 16)));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = ((((Senabled_interruptsS))<<2));
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 3;
+  goto L16918;}
+ L15976: {
+  if ((s48_Spending_interruptPS)) {
+    if ((s48_Spending_eventsPS)) {
+      s48_Spending_eventsPS = 0;
+      check_events_return_tag = 3;
+      goto check_events;
+     check_events_return_3:
+      v_1156X = check_events0_return_value;
+      if (v_1156X) {
+        arg0K0 = stack_arg_count_1116X;
+        goto L16894;}
+      else {
+        goto L15980;}}
+    else {
+      arg0K0 = stack_arg_count_1116X;
+      goto L16894;}}
+  else {
+    goto L15980;}}
+ L16033: {
+  okayP_1157X = arg2K0;
+  key_1158X = arg0K1;
+  if (okayP_1157X) {
+    arg0K0 = key_1158X;
+    goto L15987;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = key_1158X;
+    goto L15987;}}
+ L16398: {
+  v_1159X = arg0K0;
+  merged_arg0K0 = v_1159X;
+  merged_arg0K1 = stack_arg_count_784X;
+  merged_arg0K2 = list_args_785X;
+  merged_arg0K3 = list_arg_count_786X;
+  rest_list_setup_return_tag = 2;
+  goto rest_list_setup;
+ rest_list_setup_return_2:
+  *((long *) (SstackS)) = (((final_stack_arg_count_1121X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((total_arg_count_790X)<<2));
+  SstackS = ((SstackS) + -4);
+  arg0K0 = skip_1077X;
+  arg0K1 = (3 + final_stack_arg_count_1121X);
+  goto L16361;}
+ L26708: {
+  v_1160X = ps_close_fd(index_1123X);
+  arg0K0 = v_1160X;
+  goto L26703;}
+ L26703: {
+  status_1161X = arg0K0;
+  if ((status_1161X == NO_ERRORS)) {
+    push_exception_continuationB(reason_1125X, 1);
+    *((long *) (SstackS)) = arg2_999X;
+    SstackS = ((SstackS) + -4);
+    *((long *) (SstackS)) = (((mode_1000X)<<2));
+    SstackS = ((SstackS) + -4);
+    arg0K0 = 2;
+    goto L16665;}
+  else {
+    channel_close_error(status_1161X, index_1123X, arg2_999X);
+    push_exception_continuationB(reason_1125X, 1);
+    *((long *) (SstackS)) = arg2_999X;
+    SstackS = ((SstackS) + -4);
+    *((long *) (SstackS)) = (((mode_1000X)<<2));
+    SstackS = ((SstackS) + -4);
+    arg0K0 = 2;
+    goto L16665;}}
+ L36458: {
+  if ((3 == (3 & arg5_1010X))) {
+    if ((16 == (31 & ((((*((long *) ((((char *) (-3 + arg5_1010X))) + -4))))>>2))))) {
+      arg0K0 = (-1 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + arg5_1010X))) + -4))))>>8)));
+      goto L36470;}
+    else {
+      goto L36466;}}
+  else {
+    goto L36466;}}
+ L36450: {
+  if ((3 == (3 & arg5_1010X))) {
+    if ((17 == (31 & ((((*((long *) ((((char *) (-3 + arg5_1010X))) + -4))))>>2))))) {
+      goto L36458;}
+    else {
+      arg0K0 = 5;
+      goto L36341;}}
+  else {
+    arg0K0 = 5;
+    goto L36341;}}
+ L36341: {
+  reason_1162X = arg0K0;
+  push_exception_continuationB(reason_1162X, 1);
+  *((long *) (SstackS)) = arg5_1010X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((start_1133X)<<2));
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = (((count_1134X)<<2));
+  SstackS = ((SstackS) + -4);
+  if (waitP_1132X) {
+    arg0K0 = 5;
+    goto L36356;}
+  else {
+    arg0K0 = 1;
+    goto L36356;}}
+ L23940: {
+  Scode_pointerS = ((Scode_pointerS) + 1);
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L12906: {
+  arg0K0 = foo_1143X;
+  arg0K1 = (*((long *) ((((char *) (-3 + foo_1143X))) + 12)));
+  goto L12844;}
+ L11669: {
+  if ((1 == thing_936X)) {
+    arg3K0 = "#f";
+    goto L11692;}
+  else {
+    arg3K0 = "#t";
+    goto L11692;}}
+ L11682: {
+  if ((3 == (3 & thing_936X))) {
+    if ((2 == (31 & ((((*((long *) ((((char *) (-3 + thing_936X))) + -4))))>>2))))) {
+      arg3K0 = "#(...)";
+      goto L11692;}
+    else {
+      goto L11686;}}
+  else {
+    goto L11686;}}
+ L16934: {
+  SvalS = (*((long *) ((((char *) (-3 + (Sinterrupt_handlersS)))) + (((i_1065X)<<2)))));
+  obj_1163X = SvalS;
+  if ((3 == (3 & obj_1163X))) {
+    if ((3 == (31 & ((((*((long *) ((((char *) (-3 + obj_1163X))) + -4))))>>2))))) {
+      goto L16951;}
+    else {
+      goto L17037;}}
+  else {
+    goto L17037;}}
+ L15980: {
+  arg1K0 = (Scode_pointerS);
+  goto L18438;}
+ L15987: {
+  v_1164X = arg0K0;
+  merged_arg0K0 = v_1164X;
+  copy_stack_into_heap_return_tag = 3;
+  goto copy_stack_into_heap;
+ copy_stack_into_heap_return_3:
+  if ((stack_slots_1115X < (64 + (((((SstackS) - (Sstack_limitS)))>>2))))) {
+    goto L15976;}
+  else {
+    ps_error("VM's stack is too small (how can this happen?)", 0);
+    goto L15976;}}
+ L36470: {
+  length_1165X = arg0K0;
+  if ((length_1165X < (start_1133X + count_1134X))) {
+    arg0K0 = 7;
+    goto L36341;}
+  else {
+    got_1166X = ps_read_fd(((((*((long *) ((((char *) (-3 + x_1091X))) + 8))))>>2)), ((((char *) (-3 + arg5_1010X))) + start_1133X), count_1134X, waitP_1132X, &eofP_1167X, &pendingP_1168X, &status_1169X);
+    if ((status_1169X == NO_ERRORS)) {
+      if (eofP_1167X) {
+        SvalS = 21;
+        Scode_pointerS = ((Scode_pointerS) + 1);
+        arg1K0 = (Scode_pointerS);
+        goto L18438;}
+      else {
+        if (pendingP_1168X) {
+          addr_1170X = (((char *) (-3 + x_1091X))) + 16;
+          S48_WRITE_BARRIER(x_1091X, addr_1170X, 5);
+          *((long *) addr_1170X) = 5;
+          s48_Spending_interruptPS = 0;
+          Senabled_interruptsS = 0;
+          arg0K0 = 13;
+          goto L36341;}
+        else {
+          SvalS = (((got_1166X)<<2));
+          Scode_pointerS = ((Scode_pointerS) + 1);
+          arg1K0 = (Scode_pointerS);
+          goto L18438;}}}
+    else {
+      push_exception_continuationB(25, 1);
+      *((long *) (SstackS)) = arg5_1010X;
+      SstackS = ((SstackS) + -4);
+      *((long *) (SstackS)) = (((start_1133X)<<2));
+      SstackS = ((SstackS) + -4);
+      *((long *) (SstackS)) = (((count_1134X)<<2));
+      SstackS = ((SstackS) + -4);
+      if (waitP_1132X) {
+        arg0K0 = 5;
+        goto L36393;}
+      else {
+        arg0K0 = 1;
+        goto L36393;}}}}
+ L36466: {
+  arg0K0 = ((long)(((unsigned long)(*((long *) ((((char *) (-3 + arg5_1010X))) + -4))))>>8));
+  goto L36470;}
+ L36356: {
+  x_1171X = arg0K0;
+  *((long *) (SstackS)) = x_1171X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = x_1091X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 5;
+  goto L16665;}
+ L11686: {
+  if ((3 == (3 & thing_936X))) {
+    if ((3 == (31 & ((((*((long *) ((((char *) (-3 + thing_936X))) + -4))))>>2))))) {
+      arg3K0 = "#{procedure}";
+      goto L11692;}
+    else {
+      arg3K0 = "???";
+      goto L11692;}}
+  else {
+    arg3K0 = "???";
+    goto L11692;}}
+ L16951: {
+  StemplateS = (SvalS);
+  Slosing_opcodeS = (0 - i_1065X);
+  arg0K0 = arg_count_1111X;
+  goto L16066;}
+ L17037: {
+  ps_error("interrupt handler is not a closure", 1, i_1065X);
+  goto L16951;}
+ L36393: {
+  x_1172X = arg0K0;
+  *((long *) (SstackS)) = x_1172X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = x_1091X;
+  SstackS = ((SstackS) + -4);
+  merged_arg0K0 = status_1169X;
+  merged_arg0K1 = key_1006X;
+  get_error_string_return_tag = 4;
+  goto get_error_string;
+ get_error_string_return_4:
+  x_1173X = get_error_string0_return_value;
+  *((long *) (SstackS)) = x_1173X;
+  SstackS = ((SstackS) + -4);
+  arg0K0 = 6;
+  goto L16665;}
+ loseD0: {
+  message_369X = merged_arg3K0;{
+  why_1174X = (((*((long *) ((SstackS) + (4 + (((nargs_739X)<<2)))))))>>2);
+  ps_write_string("Template UIDs: ", (stderr));
+  current_template_1175X = StemplateS;
+  out_1176X = stderr;
+  if ((0 == (3 & (*((long *) ((((char *) (-3 + current_template_1175X))) + 4)))))) {
+    if ((current_template_1175X == (*((long *) ((((char *) (-3 + (Sbottom_of_stackS)))) + 8))))) {
+      arg2K0 = 0;
+      goto L10518;}
+    else {
+      ps_write_integer(((((*((long *) ((((char *) (-3 + current_template_1175X))) + 4))))>>2)), out_1176X);
+      arg2K0 = 1;
+      goto L10518;}}
+  else {
+    arg2K0 = 0;
+    goto L10518;}}
+ L10518: {
+  not_firstP_1177X = arg2K0;
+  arg0K0 = (ScontS);
+  arg2K1 = not_firstP_1177X;
+  goto L10525;}
+ L10525: {
+  cont_1178X = arg0K0;
+  not_firstP_1179X = arg2K1;
+  if ((3 == (3 & cont_1178X))) {
+    if ((9 == (31 & ((((*((long *) ((((char *) (-3 + cont_1178X))) + -4))))>>2))))) {
+      template_1180X = *((long *) ((((char *) (-3 + cont_1178X))) + 8));
+      if ((0 == (3 & (*((long *) ((((char *) (-3 + template_1180X))) + 4)))))) {
+        if ((template_1180X == (*((long *) ((((char *) (-3 + (Sbottom_of_stackS)))) + 8))))) {
+          arg2K0 = not_firstP_1179X;
+          goto L10534;}
+        else {
+          if (not_firstP_1179X) {
+            ps_write_string(" <- ", out_1176X);
+            goto L10573;}
+          else {
+            goto L10573;}}}
+      else {
+        arg2K0 = not_firstP_1179X;
+        goto L10534;}}
+    else {
+      goto L16684;}}
+  else {
+    goto L16684;}}
+ L10534: {
+  v_1181X = arg2K0;
+  arg0K0 = (*((long *) (((char *) (-3 + cont_1178X)))));
+  arg2K1 = v_1181X;
+  goto L10525;}
+ L10573: {
+  ps_write_integer(((((*((long *) ((((char *) (-3 + template_1180X))) + 4))))>>2)), out_1176X);
+  arg2K0 = 1;
+  goto L10534;}
+ L16684: {
+  { long ignoreXX;
+  PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+  if ((why_1174X == 1)) {
+    if ((0 == (3 & (*((long *) (((char *) (-3 + (*((long *) ((SstackS) + (((nargs_739X)<<2))))))))))))) {
+      ps_error(message_369X, 3, opcode_740X, why_1174X, ((((*((long *) (((char *) (-3 + (*((long *) ((SstackS) + (((nargs_739X)<<2)))))))))))>>2)));
+      goto loseD0_return;}
+    else {
+      goto L16708;}}
+  else {
+    goto L16708;}}
+ L16708: {
+  ps_error(message_369X, 2, opcode_740X, why_1174X);
+  goto loseD0_return;}
+ loseD0_return:
+  switch (loseD0_return_tag) {
+  case 0: goto loseD0_return_0;
+  default: goto loseD0_return_1;
+  }}
+
+ check_events: {
+{ goto L39788;}
+ L39788: {
+  type_1182X = s48_get_next_event(&channel_1183X, &status_1184X);
+  if ((type_1182X == ALARM_EVENT)) {
+    if ((1 == (Sinterrupted_templateS))) {
+      Sinterrupted_templateS = (StemplateS);
+      arg0K0 = 1;
+      goto L15869;}
+    else {
+      arg0K0 = 1;
+      goto L15869;}}
+  else {
+    if ((type_1182X == KEYBOARD_INTERRUPT_EVENT)) {
+      arg0K0 = 2;
+      goto L15869;}
+    else {
+      if ((type_1182X == IO_COMPLETION_EVENT)) {
+        enqueue_channelB(channel_1183X, status_1184X);
+        arg0K0 = 8;
+        goto L15869;}
+      else {
+        if ((type_1182X == OS_SIGNAL_EVENT)) {
+          arg0K0 = 16;
+          goto L15869;}
+        else {
+          if ((type_1182X == NO_EVENT)) {
+            arg0K0 = 0;
+            goto L15869;}
+          else {
+            if ((type_1182X == ERROR_EVENT)) {
+              ps_write_string("OS error while getting event", (stderr));
+              { long ignoreXX;
+              PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+              ps_write_string((ps_error_string(status_1184X)), (stderr));
+              { long ignoreXX;
+              PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+              arg0K0 = 0;
+              goto L15869;}
+            else {
+              ps_write_string("unknown type of event", (stderr));
+              { long ignoreXX;
+              PS_WRITE_CHAR(10, (stderr), ignoreXX) }
+              arg0K0 = 0;
+              goto L15869;}}}}}}}
+ L15869: {
+  v_1185X = arg0K0;
+  Spending_interruptsS = (v_1185X | (Spending_interruptsS));
+  if ((type_1182X == NO_EVENT)) {
+    if ((0 == ((Spending_interruptsS) & (Senabled_interruptsS)))) {
+      s48_Spending_interruptPS = 0;
+      if ((s48_Spending_eventsPS)) {
+        s48_Spending_interruptPS = 1;
+        goto L15896;}
+      else {
+        goto L15896;}}
+    else {
+      s48_Spending_interruptPS = 1;
+      goto L15896;}}
+  else {
+    goto L39788;}}
+ L15896: {
+  if ((s48_Spending_interruptPS)) {
+    if ((s48_Spending_eventsPS)) {
+      s48_Spending_eventsPS = 0;
+      goto L39788;}
+    else {
+      check_events0_return_value = 1;
+      goto check_events_return;}}
+  else {
+    check_events0_return_value = 0;
+    goto check_events_return;}}
+ check_events_return:
+  switch (check_events_return_tag) {
+  case 0: goto check_events_return_0;
+  case 1: goto check_events_return_1;
+  case 2: goto check_events_return_2;
+  default: goto check_events_return_3;
+  }}
+
+ rest_list_setup: {
+  wants_stack_args_365X = merged_arg0K0;
+  stack_arg_count_366X = merged_arg0K1;
+  list_args_367X = merged_arg0K2;
+  list_arg_count_368X = merged_arg0K3;{
+  if ((stack_arg_count_366X == wants_stack_args_365X)) {
+    merged_arg0K0 = list_args_367X;
+    merged_arg0K1 = list_arg_count_368X;
+    copy_listS_return_tag = 1;
+    goto copy_listS;
+   copy_listS_return_1:
+    x_1186X = copy_listS0_return_value;
+    *((long *) (SstackS)) = x_1186X;
+    SstackS = ((SstackS) + -4);
+    goto rest_list_setup_return;}
+  else {
+    if ((stack_arg_count_366X < wants_stack_args_365X)) {
+      count_1187X = wants_stack_args_365X - stack_arg_count_366X;
+      merged_arg0K0 = list_args_367X;
+      merged_arg0K1 = count_1187X;
+      push_list_return_tag = 3;
+      goto push_list;
+     push_list_return_3:
+      v_1188X = push_list0_return_value;
+      merged_arg0K0 = v_1188X;
+      merged_arg0K1 = (list_arg_count_368X - count_1187X);
+      copy_listS_return_tag = 2;
+      goto copy_listS;
+     copy_listS_return_2:
+      x_1189X = copy_listS0_return_value;
+      *((long *) (SstackS)) = x_1189X;
+      SstackS = ((SstackS) + -4);
+      goto rest_list_setup_return;}
+    else {
+      merged_arg0K0 = list_args_367X;
+      merged_arg0K1 = list_arg_count_368X;
+      copy_listS_return_tag = 3;
+      goto copy_listS;
+     copy_listS_return_3:
+      v_1190X = copy_listS0_return_value;
+      merged_arg0K0 = v_1190X;
+      merged_arg0K1 = (stack_arg_count_366X - wants_stack_args_365X);
+      pop_args_GlistS_return_tag = 5;
+      goto pop_args_GlistS;
+     pop_args_GlistS_return_5:
+      x_1191X = pop_args_GlistS0_return_value;
+      *((long *) (SstackS)) = x_1191X;
+      SstackS = ((SstackS) + -4);
+      goto rest_list_setup_return;}}}
+ rest_list_setup_return:
+  switch (rest_list_setup_return_tag) {
+  case 0: goto rest_list_setup_return_0;
+  case 1: goto rest_list_setup_return_1;
+  default: goto rest_list_setup_return_2;
+  }}
+
+ push_list: {
+  list_363X = merged_arg0K0;
+  count_364X = merged_arg0K1;{
+  *((long *) (SstackS)) = list_363X;
+  SstackS = ((SstackS) + -4);
+  if ((count_364X < (64 + (((((SstackS) - (Sstack_limitS)))>>2))))) {
+    goto L15285;}
+  else {
+    space_1192X = 1 + (((((Sstack_endS) - (SstackS)))>>2));
+    v_1193X = AVAILABLEp(space_1192X);
+    if (v_1193X) {
+      arg2K0 = 1;
+      arg0K1 = 0;
+      goto L15369;}
+    else {
+      collect_saving_temps(1, 1, &temp1_1194X);
+      v_1195X = AVAILABLEp(space_1192X);
+      if (v_1195X) {
+        arg2K0 = 1;
+        arg0K1 = 0;
+        goto L15369;}
+      else {
+        arg2K0 = 0;
+        arg0K1 = 0;
+        goto L15369;}}}}
+ L15285: {
+  SstackS = ((SstackS) + 4);
+  list_1196X = *((long *) (SstackS));
+  arg0K0 = count_364X;
+  arg0K1 = list_1196X;
+  goto L15294;}
+ L15369: {
+  okayP_1197X = arg2K0;
+  key_1198X = arg0K1;
+  if (okayP_1197X) {
+    arg0K0 = key_1198X;
+    goto L15320;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = key_1198X;
+    goto L15320;}}
+ L15294: {
+  i_1199X = arg0K0;
+  l_1200X = arg0K1;
+  if ((0 < i_1199X)) {
+    *((long *) (SstackS)) = (*((long *) (((char *) (-3 + l_1200X)))));
+    SstackS = ((SstackS) + -4);
+    arg0K0 = (-1 + i_1199X);
+    arg0K1 = (*((long *) ((((char *) (-3 + l_1200X))) + 4)));
+    goto L15294;}
+  else {
+    push_list0_return_value = l_1200X;
+    goto push_list_return;}}
+ L15320: {
+  v_1201X = arg0K0;
+  merged_arg0K0 = v_1201X;
+  copy_stack_into_heap_return_tag = 4;
+  goto copy_stack_into_heap;
+ copy_stack_into_heap_return_4:
+  if ((count_364X < (64 + (((((SstackS) - (Sstack_limitS)))>>2))))) {
+    goto L15285;}
+  else {
+    ps_error("VM's stack is too small (how can this happen?)", 0);
+    goto L15285;}}
+ push_list_return:
+  switch (push_list_return_tag) {
+  case 0: goto push_list_return_0;
+  case 1: goto push_list_return_1;
+  case 2: goto push_list_return_2;
+  default: goto push_list_return_3;
+  }}
+
+ copy_stack_into_heap: {
+  key_362X = merged_arg0K0;{
+  arg1K0 = ((SstackS) + 4);
+  arg0K1 = 0;
+  goto L13514;}
+ L13514: {
+  p_1202X = arg1K0;
+  i_1203X = arg0K1;
+  if ((2 == (3 & (*((long *) p_1202X))))) {
+    if ((22 == (*((long *) p_1202X)))) {
+      arg0K0 = (-1 + i_1203X);
+      goto L13501;}
+    else {
+      arg0K0 = i_1203X;
+      goto L13501;}}
+  else {
+    arg1K0 = (p_1202X + 4);
+    arg0K1 = (1 + i_1203X);
+    goto L13514;}}
+ L13501: {
+  arg_count_1204X = arg0K0;
+  top_1205X = SstackS;
+  if ((1 == (ScontS))) {
+    goto L13506;}
+  else {
+    merged_arg0K0 = key_362X;
+    merged_arg0K1 = 1;
+    really_preserve_continuation_return_tag = 1;
+    goto really_preserve_continuation;
+   really_preserve_continuation_return_1:
+    goto L13506;}}
+ L13506: {
+  stob_1206X = ScontS;
+  arg1K0 = ((((char *) (-3 + stob_1206X))) + -8);
+  arg1K1 = (top_1205X + (((arg_count_1204X)<<2)));
+  goto L13539;}
+ L13539: {
+  loc_1207X = arg1K0;
+  arg_1208X = arg1K1;
+  if ((top_1205X < arg_1208X)) {
+    *((long *) loc_1207X) = (*((long *) arg_1208X));
+    arg1K0 = (loc_1207X + -4);
+    arg1K1 = (arg_1208X + -4);
+    goto L13539;}
+  else {
+    SstackS = loc_1207X;
+    goto copy_stack_into_heap_return;}}
+ copy_stack_into_heap_return:
+  switch (copy_stack_into_heap_return_tag) {
+  case 0: goto copy_stack_into_heap_return_0;
+  case 1: goto copy_stack_into_heap_return_1;
+  case 2: goto copy_stack_into_heap_return_2;
+  case 3: goto copy_stack_into_heap_return_3;
+  default: goto copy_stack_into_heap_return_4;
+  }}
+
+ really_preserve_continuation: {
+  key_360X = merged_arg0K0;
+  reason_361X = merged_arg0K1;{
+  p_1209X = SenvS;
+  if ((3 == (3 & p_1209X))) {
+    if ((p_1209X < (((long) (Sstack_beginS))))) {
+      goto L12690;}
+    else {
+      if (((((long) (Sstack_endS))) < p_1209X)) {
+        goto L12690;}
+      else {
+        merged_arg0K0 = (SenvS);
+        merged_arg0K1 = (ScontS);
+        merged_arg0K2 = key_360X;
+        merged_arg0K3 = reason_361X;
+        save_env_in_heap_return_tag = 1;
+        goto save_env_in_heap;
+       save_env_in_heap_return_1:
+        v_1210X = save_env_in_heap0_return_value;
+        SenvS = v_1210X;
+        goto L12690;}}}
+  else {
+    goto L12690;}}
+ L12690: {
+  end_1211X = *((long *) (((char *) (-3 + (Sbottom_of_stackS)))));
+  arg0K0 = (ScontS);
+  arg0K1 = (Sbottom_of_stackS);
+  goto L12643;}
+ L12643: {
+  cont_1212X = arg0K0;
+  previous_1213X = arg0K1;
+  if ((cont_1212X == (Sbottom_of_stackS))) {
+    *((long *) (((char *) (-3 + previous_1213X)))) = end_1211X;
+    ScontS = (Sbottom_of_stackS);
+    really_preserve_continuation0_return_value = (*((long *) (((char *) (-3 + (Sbottom_of_stackS))))));
+    goto really_preserve_continuation_return;}
+  else {
+    p_1214X = *((long *) ((((char *) (-3 + cont_1212X))) + 12));
+    if ((3 == (3 & p_1214X))) {
+      if ((p_1214X < (((long) (Sstack_beginS))))) {
+        goto L12661;}
+      else {
+        if (((((long) (Sstack_endS))) < p_1214X)) {
+          goto L12661;}
+        else {
+          merged_arg0K0 = (*((long *) ((((char *) (-3 + cont_1212X))) + 12)));
+          merged_arg0K1 = cont_1212X;
+          merged_arg0K2 = key_360X;
+          merged_arg0K3 = reason_361X;
+          save_env_in_heap_return_tag = 2;
+          goto save_env_in_heap;
+         save_env_in_heap_return_2:
+          goto L12661;}}}
+    else {
+      goto L12661;}}}
+ L12661: {
+  header_1215X = *((long *) ((((char *) (-3 + cont_1212X))) + -4));
+  addr_1216X = ALLOCATE_SPACE((31 & (((header_1215X)>>2))), (4 + ((long)(((unsigned long)header_1215X)>>8))));
+  data_addr_1217X = addr_1216X + 4;
+  *((long *) addr_1216X) = header_1215X;
+  memcpy((void *)data_addr_1217X, (void *)(((char *) (-3 + cont_1212X))),((long)(((unsigned long)header_1215X)>>8)));
+  new_1218X = 3 + (((long) data_addr_1217X));
+  *((long *) (((char *) (-3 + previous_1213X)))) = new_1218X;
+  arg0K0 = (*((long *) (((char *) (-3 + new_1218X)))));
+  arg0K1 = new_1218X;
+  goto L12643;}
+ really_preserve_continuation_return:
+  switch (really_preserve_continuation_return_tag) {
+  case 0: goto really_preserve_continuation_return_0;
+  default: goto really_preserve_continuation_return_1;
+  }}
+
+ copy_env: {
+  env_359X = merged_arg0K0;{
+  header_1219X = *((long *) ((((char *) (-3 + env_359X))) + -4));
+  addr_1220X = ALLOCATE_SPACE((31 & (((header_1219X)>>2))), (4 + ((long)(((unsigned long)header_1219X)>>8))));
+  data_addr_1221X = addr_1220X + 4;
+  *((long *) addr_1220X) = header_1219X;
+  memcpy((void *)data_addr_1221X, (void *)(((char *) (-3 + env_359X))),((long)(((unsigned long)header_1219X)>>8)));
+  new_1222X = 3 + (((long) data_addr_1221X));
+  addr_1223X = ((char *) (-3 + env_359X));
+  S48_WRITE_BARRIER(env_359X, addr_1223X, 22);
+  *((long *) addr_1223X) = 22;
+  *((long *) ((((char *) (-3 + env_359X))) + -4)) = new_1222X;
+  copy_env0_return_value = new_1222X;
+  goto copy_env_return;}
+ copy_env_return:
+  switch (copy_env_return_tag) {
+  case 0: goto copy_env_return_0;
+  default: goto copy_env_return_1;
+  }}
+
+ save_env_in_heap: {
+  env_355X = merged_arg0K0;
+  cont_356X = merged_arg0K1;
+  key_357X = merged_arg0K2;
+  reason_358X = merged_arg0K3;{
+  merged_arg0K0 = env_355X;
+  merged_arg0K1 = key_357X;
+  merged_arg0K2 = reason_358X;
+  copy_env_return_tag = 0;
+  goto copy_env;
+ copy_env_return_0:
+  top_1224X = copy_env0_return_value;
+  arg0K0 = top_1224X;
+  goto L11922;}
+ L11922: {
+  env_1225X = arg0K0;
+  p_1226X = *((long *) (((char *) (-3 + env_1225X))));
+  if ((3 == (3 & p_1226X))) {
+    if ((p_1226X < (((long) (Sstack_beginS))))) {
+      goto L11941;}
+    else {
+      if (((((long) (Sstack_endS))) < p_1226X)) {
+        goto L11941;}
+      else {
+        merged_arg0K0 = (*((long *) (((char *) (-3 + env_1225X)))));
+        merged_arg0K1 = key_357X;
+        merged_arg0K2 = reason_358X;
+        copy_env_return_tag = 1;
+        goto copy_env;
+       copy_env_return_1:
+        new_1227X = copy_env0_return_value;
+        addr_1228X = ((char *) (-3 + env_1225X));
+        S48_WRITE_BARRIER(env_1225X, addr_1228X, new_1227X);
+        *((long *) addr_1228X) = new_1227X;
+        arg0K0 = new_1227X;
+        goto L11922;}}}
+  else {
+    goto L11941;}}
+ L11941: {
+  arg0K0 = cont_356X;
+  goto L11945;}
+ L11945: {
+  cont_1229X = arg0K0;
+  env_1230X = *((long *) ((((char *) (-3 + cont_1229X))) + 12));
+  if ((3 == (3 & env_1230X))) {
+    if ((3 == (3 & (*((long *) ((((char *) (-3 + env_1230X))) + -4)))))) {
+      *((long *) ((((char *) (-3 + cont_1229X))) + 12)) = (*((long *) ((((char *) (-3 + env_1230X))) + -4)));
+      arg0K0 = (*((long *) (((char *) (-3 + cont_1229X)))));
+      goto L11945;}
+    else {
+      save_env_in_heap0_return_value = top_1224X;
+      goto save_env_in_heap_return;}}
+  else {
+    save_env_in_heap0_return_value = top_1224X;
+    goto save_env_in_heap_return;}}
+ save_env_in_heap_return:
+  switch (save_env_in_heap_return_tag) {
+  case 0: goto save_env_in_heap_return_0;
+  case 1: goto save_env_in_heap_return_1;
+  default: goto save_env_in_heap_return_2;
+  }}
+
+ pop_args_GlistS: {
+  start_353X = merged_arg0K0;
+  count_354X = merged_arg0K1;{
+  space_1231X = 3 * count_354X;
+  v_1232X = AVAILABLEp(space_1231X);
+  if (v_1232X) {
+    arg2K0 = 1;
+    arg0K1 = start_353X;
+    goto L14260;}
+  else {
+    temp0_1233X = collect_saving_temps(start_353X, 1, &temp1_1234X);
+    v_1235X = AVAILABLEp(space_1231X);
+    if (v_1235X) {
+      arg2K0 = 1;
+      arg0K1 = temp0_1233X;
+      goto L14260;}
+    else {
+      arg2K0 = 0;
+      arg0K1 = temp0_1233X;
+      goto L14260;}}}
+ L14260: {
+  okayP_1236X = arg2K0;
+  temp_1237X = arg0K1;
+  if (okayP_1236X) {
+    arg0K0 = temp_1237X;
+    goto L14234;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = temp_1237X;
+    goto L14234;}}
+ L14234: {
+  start_1238X = arg0K0;
+  arg0K0 = start_1238X;
+  arg0K1 = count_354X;
+  goto L14243;}
+ L14243: {
+  args_1239X = arg0K0;
+  count_1240X = arg0K1;
+  if ((0 == count_1240X)) {
+    pop_args_GlistS0_return_value = args_1239X;
+    goto pop_args_GlistS_return;}
+  else {
+    SstackS = ((SstackS) + 4);
+    a_1241X = *((long *) (SstackS));
+    addr_1242X = ALLOCATE_SPACE(0, 12);
+    *((long *) addr_1242X) = 2050;
+    x_1243X = 3 + (((long) (addr_1242X + 4)));
+    *((long *) (((char *) (-3 + x_1243X)))) = a_1241X;
+    *((long *) ((((char *) (-3 + x_1243X))) + 4)) = args_1239X;
+    arg0K0 = x_1243X;
+    arg0K1 = (-1 + count_1240X);
+    goto L14243;}}
+ pop_args_GlistS_return:
+  switch (pop_args_GlistS_return_tag) {
+  case 0: goto pop_args_GlistS_return_0;
+  case 1: goto pop_args_GlistS_return_1;
+  case 2: goto pop_args_GlistS_return_2;
+  case 3: goto pop_args_GlistS_return_3;
+  case 4: goto pop_args_GlistS_return_4;
+  default: goto pop_args_GlistS_return_5;
+  }}
+
+ copy_listS: {
+  list_351X = merged_arg0K0;
+  length_352X = merged_arg0K1;{
+  if ((0 == length_352X)) {
+    copy_listS0_return_value = 25;
+    goto copy_listS_return;}
+  else {
+    space_1244X = 3 * length_352X;
+    v_1245X = AVAILABLEp(space_1244X);
+    if (v_1245X) {
+      arg2K0 = 1;
+      arg0K1 = list_351X;
+      goto L14139;}
+    else {
+      temp0_1246X = collect_saving_temps(list_351X, 1, &temp1_1247X);
+      v_1248X = AVAILABLEp(space_1244X);
+      if (v_1248X) {
+        arg2K0 = 1;
+        arg0K1 = temp0_1246X;
+        goto L14139;}
+      else {
+        arg2K0 = 0;
+        arg0K1 = temp0_1246X;
+        goto L14139;}}}}
+ L14139: {
+  okayP_1249X = arg2K0;
+  temp_1250X = arg0K1;
+  if (okayP_1249X) {
+    arg0K0 = temp_1250X;
+    goto L14097;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = temp_1250X;
+    goto L14097;}}
+ L14097: {
+  list_1251X = arg0K0;
+  a_1252X = *((long *) (((char *) (-3 + list_1251X))));
+  addr_1253X = ALLOCATE_SPACE(0, 12);
+  *((long *) addr_1253X) = 2050;
+  x_1254X = 3 + (((long) (addr_1253X + 4)));
+  *((long *) (((char *) (-3 + x_1254X)))) = a_1252X;
+  *((long *) ((((char *) (-3 + x_1254X))) + 4)) = 25;
+  arg0K0 = (*((long *) ((((char *) (-3 + list_1251X))) + 4)));
+  arg0K1 = x_1254X;
+  goto L14112;}
+ L14112: {
+  l_1255X = arg0K0;
+  last_1256X = arg0K1;
+  if ((25 == l_1255X)) {
+    copy_listS0_return_value = x_1254X;
+    goto copy_listS_return;}
+  else {
+    a_1257X = *((long *) (((char *) (-3 + l_1255X))));
+    addr_1258X = ALLOCATE_SPACE(0, 12);
+    *((long *) addr_1258X) = 2050;
+    x_1259X = 3 + (((long) (addr_1258X + 4)));
+    *((long *) (((char *) (-3 + x_1259X)))) = a_1257X;
+    *((long *) ((((char *) (-3 + x_1259X))) + 4)) = 25;
+    addr_1260X = (((char *) (-3 + last_1256X))) + 4;
+    S48_WRITE_BARRIER(last_1256X, addr_1260X, x_1259X);
+    *((long *) addr_1260X) = x_1259X;
+    arg0K0 = (*((long *) ((((char *) (-3 + l_1255X))) + 4)));
+    arg0K1 = x_1259X;
+    goto L14112;}}
+ copy_listS_return:
+  switch (copy_listS_return_tag) {
+  case 0: goto copy_listS_return_0;
+  case 1: goto copy_listS_return_1;
+  case 2: goto copy_listS_return_2;
+  default: goto copy_listS_return_3;
+  }}
+
+ copy_continuation_from_heapB: {
+  cont_350X = merged_arg0K0;{
+  top_1261X = (((char *) (-3 + (Sbottom_of_stackS)))) + (-8 - (-4 & (3 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + cont_350X))) + -4))))>>8)))));
+  new_cont_1262X = 3 + (((long) (top_1261X + 4)));
+  SstackS = (top_1261X + -4);
+  ScontS = new_cont_1262X;
+  v_1263X = (((3 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + cont_350X))) + -4))))>>8))))>>2);
+  memcpy((void *)top_1261X, (void *)((((char *) (-3 + cont_350X))) + -4),(4 + (((v_1263X)<<2))));
+  *((long *) (((char *) (-3 + (Sbottom_of_stackS))))) = (*((long *) (((char *) (-3 + new_cont_1262X)))));
+  *((long *) (((char *) (-3 + new_cont_1262X)))) = (Sbottom_of_stackS);
+  copy_continuation_from_heapB0_return_value = new_cont_1262X;
+  goto copy_continuation_from_heapB_return;}
+ copy_continuation_from_heapB_return:
+  switch (copy_continuation_from_heapB_return_tag) {
+  case 0: goto copy_continuation_from_heapB_return_0;
+  default: goto copy_continuation_from_heapB_return_1;
+  }}
+
+ get_current_port: {
+  marker_349X = merged_arg0K0;{
+  thread_1264X = Scurrent_threadS;
+  if ((3 == (3 & thread_1264X))) {
+    if ((8 == (31 & ((((*((long *) ((((char *) (-3 + thread_1264X))) + -4))))>>2))))) {
+      if ((1 < ((((3 + ((long)(((unsigned long)(*((long *) ((((char *) (-3 + thread_1264X))) + -4))))>>8))))>>2)))) {
+        arg0K0 = (*((long *) ((((char *) (-3 + thread_1264X))) + 4)));
+        goto L10214;}
+      else {
+        goto L10264;}}
+    else {
+      goto L10264;}}
+  else {
+    goto L10264;}}
+ L10214: {
+  env_1265X = arg0K0;
+  if ((3 == (3 & env_1265X))) {
+    if ((0 == (31 & ((((*((long *) ((((char *) (-3 + env_1265X))) + -4))))>>2))))) {
+      obj_1266X = *((long *) (((char *) (-3 + env_1265X))));
+      if ((3 == (3 & obj_1266X))) {
+        if ((0 == (31 & ((((*((long *) ((((char *) (-3 + obj_1266X))) + -4))))>>2))))) {
+          if ((marker_349X == (*((long *) (((char *) (-3 + (*((long *) (((char *) (-3 + env_1265X)))))))))))) {
+            get_current_port0_return_value = (*((long *) ((((char *) (-3 + (*((long *) (((char *) (-3 + env_1265X)))))))) + 4)));
+            goto get_current_port_return;}
+          else {
+            arg0K0 = (*((long *) ((((char *) (-3 + env_1265X))) + 4)));
+            goto L10214;}}
+        else {
+          goto L10286;}}
+      else {
+        goto L10286;}}
+    else {
+      goto L10286;}}
+  else {
+    goto L10286;}}
+ L10264: {
+  ps_error("current thread is not a record", 0);
+  get_current_port0_return_value = v_1267X;
+  goto get_current_port_return;}
+ L10286: {
+  if ((25 == env_1265X)) {
+    if (((((marker_349X)>>2)) == 1)) {
+      arg3K0 = "dynamic environment doesn't have current-output-port";
+      goto L10240;}
+    else {
+      arg3K0 = "dynamic environment doesn't have current-input-port";
+      goto L10240;}}
+  else {
+    ps_error("dynamic environment is not a proper list", 0);
+    get_current_port0_return_value = v_1268X;
+    goto get_current_port_return;}}
+ L10240: {
+  v_1269X = arg3K0;
+  ps_error(v_1269X, 0);
+  get_current_port0_return_value = v_1270X;
+  goto get_current_port_return;}
+ get_current_port_return:
+  switch (get_current_port_return_tag) {
+  case 0: goto get_current_port_return_0;
+  case 1: goto get_current_port_return_1;
+  default: goto get_current_port_return_2;
+  }}
+
+ okay_argument_list: {
+  list_348X = merged_arg0K0;{
+  arg0K0 = list_348X;
+  arg0K1 = 0;
+  arg0K2 = list_348X;
+  arg2K3 = 0;
+  goto L10081;}
+ L10081: {
+  fast_1271X = arg0K0;
+  len_1272X = arg0K1;
+  slow_1273X = arg0K2;
+  move_slowP_1274X = arg2K3;
+  if ((25 == fast_1271X)) {
+    okay_argument_list0_return_value = 1;
+    okay_argument_list1_return_value = len_1272X;
+    goto okay_argument_list_return;}
+  else {
+    if ((3 == (3 & fast_1271X))) {
+      if ((0 == (31 & ((((*((long *) ((((char *) (-3 + fast_1271X))) + -4))))>>2))))) {
+        if (move_slowP_1274X) {
+          if ((fast_1271X == slow_1273X)) {
+            okay_argument_list0_return_value = 0;
+            okay_argument_list1_return_value = 0;
+            goto okay_argument_list_return;}
+          else {
+            arg0K0 = (*((long *) ((((char *) (-3 + fast_1271X))) + 4)));
+            arg0K1 = (1 + len_1272X);
+            arg0K2 = (*((long *) ((((char *) (-3 + slow_1273X))) + 4)));
+            arg2K3 = 0;
+            goto L10081;}}
+        else {
+          arg0K0 = (*((long *) ((((char *) (-3 + fast_1271X))) + 4)));
+          arg0K1 = (1 + len_1272X);
+          arg0K2 = slow_1273X;
+          arg2K3 = 1;
+          goto L10081;}}
+      else {
+        okay_argument_list0_return_value = 0;
+        okay_argument_list1_return_value = 0;
+        goto okay_argument_list_return;}}
+    else {
+      okay_argument_list0_return_value = 0;
+      okay_argument_list1_return_value = 0;
+      goto okay_argument_list_return;}}}
+ okay_argument_list_return:
+  switch (okay_argument_list_return_tag) {
+  case 0: goto okay_argument_list_return_0;
+  default: goto okay_argument_list_return_1;
+  }}
+
+ get_error_string: {
+  status_347X = merged_arg0K0;{
+  string_1275X = ps_error_string(status_347X);
+  x_1276X = strlen((char *) string_1275X);
+  if ((x_1276X < 256)) {
+    arg0K0 = x_1276X;
+    goto L9589;}
+  else {
+    arg0K0 = 256;
+    goto L9589;}}
+ L9589: {
+  len_1277X = arg0K0;
+  len_1278X = 1 + len_1277X;
+  addr_1279X = ALLOCATE_SPACE(16, (4 + len_1278X));
+  *((long *) addr_1279X) = (66 + (((len_1278X)<<8)));
+  string_1280X = 3 + (((long) (addr_1279X + 4)));
+  *((unsigned char *) ((((char *) (-3 + string_1280X))) + len_1277X)) = 0;
+  arg0K0 = 0;
+  goto L9599;}
+ L9599: {
+  i_1281X = arg0K0;
+  if ((i_1281X == len_1277X)) {
+    get_error_string0_return_value = string_1280X;
+    goto get_error_string_return;}
+  else {
+    *((unsigned char *) ((((char *) (-3 + string_1280X))) + i_1281X)) = ((*(string_1275X + i_1281X)));
+    arg0K0 = (1 + i_1281X);
+    goto L9599;}}
+ get_error_string_return:
+  switch (get_error_string_return_tag) {
+  case 0: goto get_error_string_return_0;
+  case 1: goto get_error_string_return_1;
+  case 2: goto get_error_string_return_2;
+  case 3: goto get_error_string_return_3;
+  default: goto get_error_string_return_4;
+  }}
+
+ pop_continuationB: {
+{ cont_1282X = ScontS;
+  tem_1283X = *((long *) ((((char *) (-3 + cont_1282X))) + 8));
+  pc_1284X = *((long *) ((((char *) (-3 + cont_1282X))) + 4));
+  StemplateS = tem_1283X;
+  Scode_pointerS = ((((char *) (-3 + (*((long *) (((char *) (-3 + tem_1283X)))))))) + (((pc_1284X)>>2)));
+  SenvS = (*((long *) ((((char *) (-3 + cont_1282X))) + 12)));
+  ScontS = (*((long *) (((char *) (-3 + cont_1282X)))));
+  SstackS = ((((char *) (-3 + cont_1282X))) + 12);
+  goto pop_continuationB_return;}
+ pop_continuationB_return:
+  switch (pop_continuationB_return_tag) {
+  case 0: goto pop_continuationB_return_0;
+  case 1: goto pop_continuationB_return_1;
+  default: goto pop_continuationB_return_2;
+  }}
+
+}
+long s48_call_startup_procedure(char **startup_vector_1285X, long startup_vector_length_1286X)
+{
+  char arg2K0;
+  long arg0K1;
+  long arg0K0;
+  long v_1335X;
+  long x_1334X;
+  long x_1333X;
+  char * addr_1332X;
+  long b_1331X;
+  long channel_1330X;
+  long x_1329X;
+  char * addr_1328X;
+  long b_1327X;
+  long channel_1326X;
+  long x_1325X;
+  char * addr_1324X;
+  long b_1323X;
+  long channel_1322X;
+  long key_1321X;
+  long key_1320X;
+  char okayP_1319X;
+  char v_1318X;
+  long temp1_1317X;
+  char v_1316X;
+  long space_1315X;
+  long i_1314X;
+  long length_1313X;
+  long *v_1312X;
+  long v_1311X;
+  long v_1310X;
+  long y_1309X;
+  long x_1308X;
+  long v_1307X;
+  long x_1306X;
+  long y_1305X;
+  char * addr_1304X;
+  long value_1303X;
+  long x_1302X;
+  long y_1301X;
+  long i_1300X;
+  long vector_1299X;
+  char * addr_1298X;
+  long len_1297X;
+  long key_1296X;
+  long key_1295X;
+  char okayP_1294X;
+  char v_1293X;
+  long temp1_1292X;
+  char v_1291X;
+  long space_1290X;
+  long size_1289X;
+  long i_1288X;
+  long tem_1287X;
+ {  SstackS = ((((char *) (-3 + (Sbottom_of_stackS)))) + -8);
+  *((long *) (((char *) (-3 + (Sbottom_of_stackS))))) = 1;
+  ScontS = (Sbottom_of_stackS);
+  SenvS = 13;
+  tem_1287X = Sinterrupt_templateS;
+  StemplateS = tem_1287X;
+  Scode_pointerS = (((char *) (-3 + (*((long *) (((char *) (-3 + tem_1287X))))))));
+  SvalS = 13;
+  Scurrent_threadS = 25;
+  Ssession_dataS = 25;
+  Sexception_handlersS = 25;
+  Sinterrupt_handlersS = 25;
+  Senabled_interruptsS = 0;
+  Sfinalizer_alistS = 25;
+  Sfinalize_theseS = 25;
+  Spending_interruptsS = 0;
+  s48_Spending_interruptPS = 0;
+  Sinterrupted_templateS = 1;
+  arg0K0 = 0;
+  arg0K1 = 0;
+  goto L15603;}
+ L15603: {
+  i_1288X = arg0K0;
+  size_1289X = arg0K1;
+  if ((i_1288X == startup_vector_length_1286X)) {
+    space_1290X = 1 + (size_1289X + startup_vector_length_1286X);
+    v_1291X = AVAILABLEp(space_1290X);
+    if (v_1291X) {
+      arg2K0 = 1;
+      arg0K1 = 0;
+      goto L15640;}
+    else {
+      collect_saving_temps(1, 1, &temp1_1292X);
+      v_1293X = AVAILABLEp(space_1290X);
+      if (v_1293X) {
+        arg2K0 = 1;
+        arg0K1 = 0;
+        goto L15640;}
+      else {
+        arg2K0 = 0;
+        arg0K1 = 0;
+        goto L15640;}}}
+  else {
+    arg0K0 = (1 + i_1288X);
+    arg0K1 = (1 + (size_1289X + ((((4 + (strlen((char *) (*(startup_vector_1285X + i_1288X))))))>>2))));
+    goto L15603;}}
+ L15640: {
+  okayP_1294X = arg2K0;
+  key_1295X = arg0K1;
+  if (okayP_1294X) {
+    arg0K0 = key_1295X;
+    goto L15618;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = key_1295X;
+    goto L15618;}}
+ L15618: {
+  key_1296X = arg0K0;
+  len_1297X = ((startup_vector_length_1286X)<<2);
+  addr_1298X = ALLOCATE_SPACE(2, (4 + len_1297X));
+  *((long *) addr_1298X) = (10 + (((len_1297X)<<8)));
+  vector_1299X = 3 + (((long) (addr_1298X + 4)));
+  arg0K0 = 0;
+  goto L15676;}
+ L15676: {
+  i_1300X = arg0K0;
+  if ((i_1300X == startup_vector_length_1286X)) {
+    *((long *) (SstackS)) = vector_1299X;
+    SstackS = ((SstackS) + -4);
+    y_1301X = fileno((stderr));
+    x_1302X = fileno((stdout));
+    if ((x_1302X < y_1301X)) {
+      arg0K0 = y_1301X;
+      goto L14512;}
+    else {
+      arg0K0 = x_1302X;
+      goto L14512;}}
+  else {
+    value_1303X = enter_string((*(startup_vector_1285X + i_1300X)), key_1296X);
+    addr_1304X = (((char *) (-3 + vector_1299X))) + (((i_1300X)<<2));
+    S48_WRITE_BARRIER(vector_1299X, addr_1304X, value_1303X);
+    *((long *) addr_1304X) = value_1303X;
+    arg0K0 = (1 + i_1300X);
+    goto L15676;}}
+ L14512: {
+  y_1305X = arg0K0;
+  x_1306X = fileno((stdin));
+  if ((x_1306X < y_1305X)) {
+    arg0K0 = y_1305X;
+    goto L14514;}
+  else {
+    arg0K0 = x_1306X;
+    goto L14514;}}
+ L14514: {
+  v_1307X = arg0K0;
+  x_1308X = Snumber_of_channelsS;
+  y_1309X = 1 + v_1307X;
+  if ((x_1308X < y_1309X)) {
+    arg0K0 = y_1309X;
+    goto L14516;}
+  else {
+    arg0K0 = x_1308X;
+    goto L14516;}}
+ L14516: {
+  v_1310X = arg0K0;
+  Snumber_of_channelsS = v_1310X;
+  v_1311X = fileno((stdin));
+  Svm_channelsS = ((long*)malloc(sizeof(long) * (Snumber_of_channelsS)));
+  Spending_channels_headS = 1;
+  Spending_channels_tailS = 1;
+  if ((NULL == (Svm_channelsS))) {
+    ps_error("out of memory, unable to continue", 0);
+    goto L14538;}
+  else {
+    goto L14538;}}
+ L14538: {
+  v_1312X = Svm_channelsS;
+  length_1313X = Snumber_of_channelsS;
+  arg0K0 = 0;
+  goto L14586;}
+ L14586: {
+  i_1314X = arg0K0;
+  if ((i_1314X < length_1313X)) {
+    *(v_1312X + i_1314X) = 1;
+    arg0K0 = (1 + i_1314X);
+    goto L14586;}
+  else {
+    space_1315X = 3 * (7 + ((((4 + (strlen((char *) "standard output"))))>>2)));
+    v_1316X = AVAILABLEp(space_1315X);
+    if (v_1316X) {
+      arg2K0 = 1;
+      arg0K1 = 0;
+      goto L14600;}
+    else {
+      collect_saving_temps(1, 1, &temp1_1317X);
+      v_1318X = AVAILABLEp(space_1315X);
+      if (v_1318X) {
+        arg2K0 = 1;
+        arg0K1 = 0;
+        goto L14600;}
+      else {
+        arg2K0 = 0;
+        arg0K1 = 0;
+        goto L14600;}}}}
+ L14600: {
+  okayP_1319X = arg2K0;
+  key_1320X = arg0K1;
+  if (okayP_1319X) {
+    arg0K0 = key_1320X;
+    goto L14544;}
+  else {
+    ps_error("Scheme48 heap overflow", 0);
+    arg0K0 = key_1320X;
+    goto L14544;}}
+ L14544: {
+  key_1321X = arg0K0;
+  channel_1322X = fileno((stdin));
+  b_1323X = enter_string("standard input", key_1321X);
+  addr_1324X = ALLOCATE_SPACE(5, 24);
+  *((long *) addr_1324X) = 5142;
+  x_1325X = 3 + (((long) (addr_1324X + 4)));
+  *((long *) (((char *) (-3 + x_1325X)))) = 4;
+  *((long *) ((((char *) (-3 + x_1325X))) + 4)) = b_1323X;
+  *((long *) ((((char *) (-3 + x_1325X))) + 8)) = (((channel_1322X)<<2));
+  *((long *) ((((char *) (-3 + x_1325X))) + 12)) = 1;
+  *((long *) ((((char *) (-3 + x_1325X))) + 16)) = 1;
+  *((Svm_channelsS) + channel_1322X) = x_1325X;
+  channel_1326X = fileno((stderr));
+  b_1327X = enter_string("standard error", key_1321X);
+  addr_1328X = ALLOCATE_SPACE(5, 24);
+  *((long *) addr_1328X) = 5142;
+  x_1329X = 3 + (((long) (addr_1328X + 4)));
+  *((long *) (((char *) (-3 + x_1329X)))) = 8;
+  *((long *) ((((char *) (-3 + x_1329X))) + 4)) = b_1327X;
+  *((long *) ((((char *) (-3 + x_1329X))) + 8)) = (((channel_1326X)<<2));
+  *((long *) ((((char *) (-3 + x_1329X))) + 12)) = 1;
+  *((long *) ((((char *) (-3 + x_1329X))) + 16)) = 1;
+  *((Svm_channelsS) + channel_1326X) = x_1329X;
+  channel_1330X = fileno((stdout));
+  b_1331X = enter_string("standard output", key_1321X);
+  addr_1332X = ALLOCATE_SPACE(5, 24);
+  *((long *) addr_1332X) = 5142;
+  x_1333X = 3 + (((long) (addr_1332X + 4)));
+  *((long *) (((char *) (-3 + x_1333X)))) = 8;
+  *((long *) ((((char *) (-3 + x_1333X))) + 4)) = b_1331X;
+  *((long *) ((((char *) (-3 + x_1333X))) + 8)) = (((channel_1330X)<<2));
+  *((long *) ((((char *) (-3 + x_1333X))) + 12)) = 1;
+  *((long *) ((((char *) (-3 + x_1333X))) + 16)) = 1;
+  *((Svm_channelsS) + channel_1330X) = x_1333X;
+  *((long *) (SstackS)) = x_1325X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = x_1333X;
+  SstackS = ((SstackS) + -4);
+  *((long *) (SstackS)) = x_1329X;
+  SstackS = ((SstackS) + -4);
+  x_1334X = s48_resumer_records();
+  *((long *) (SstackS)) = x_1334X;
+  SstackS = ((SstackS) + -4);
+  s48_initialization_completeB();
+  v_1335X = s48_startup_procedure();
+  return s48_restart(v_1335X, 5);}
+}void
+s48_init(void)
+{
+Snumber_of_channelsS = 100;
+Spending_channels_headS = 1;
+Spending_channels_tailS = 1;
+Sstack_warningPS = 1;
+Slosing_opcodeS = 0;
+Sos_signal_typeS = 1;
+Sos_signal_argumentS = 1;
+Sexternal_exceptionPS = 0;
+Sexternal_root_stackS = NULL;
+Sexternal_root_stack_baseS = NULL;
+Spermanent_external_rootsS = NULL;
+Sgc_root_procS = HtopD8861;
+Spost_gc_cleanupS = HtopD8854;
+s48_Scallback_return_stack_blockS = 1;
+s48_Spending_eventsPS = 0;
+}
diff --git a/c/scheme48vm.h b/c/scheme48vm.h
new file mode 100644
index 0000000..70ea4cf
--- /dev/null
+++ b/c/scheme48vm.h
@@ -0,0 +1,61 @@
+/*
+ * Externally visible objects defined in scheme48vm.c.
+ */
+
+#include "scheme48.h"
+
+/* initializing */
+extern void		s48_init(void);
+extern void		s48_initialize_vm(char *, long);
+
+/* running */
+extern long		s48_call_startup_procedure(char **, long);
+extern s48_value	s48_restart(s48_value proc, long nargs);
+extern s48_value	s48_Scallback_return_stack_blockS;
+	  
+/* for extension.c */
+extern void		s48_set_extension_valueB(s48_value);
+extern s48_value	s48_Sextension_valueS;
+
+/* interrupts */
+extern void		s48_note_event(void);
+extern char		s48_Spending_eventsPS;
+extern char		s48_Spending_interruptPS;
+extern void		s48_disable_interruptsB(void);
+extern void		s48_enable_interruptsB(void);
+extern void		s48_set_os_signal(s48_value type, s48_value argument);
+
+/* imported and exported bindings */	  
+extern void		s48_define_exported_binding(char *, s48_value);
+extern s48_value	s48_get_imported_binding(char *);
+
+/* for raising exceptions in external code */
+extern void		s48_setup_external_exception(s48_value exception,
+						     long nargs);
+extern s48_value	s48_resetup_external_exception(s48_value exception,
+						       long additional_nargs);
+extern void		s48_push(s48_value value);
+extern s48_value	s48_stack_ref(long offset);
+extern void		s48_stack_setB(long offset, s48_value value);
+
+/* called when writing an image */
+extern s48_value	s48_copy_symbol_table(void);
+extern void		s48_mark_traced_channels_closedB(void);
+extern s48_value	s48_cleaned_imported_bindings(void);
+extern s48_value	s48_exported_bindings(void);
+
+/* called when resuming an image */
+extern char	s48_warn_about_undefined_imported_bindings(void);
+
+/* manipulating channels */
+extern void		s48_close_channel(long);
+extern s48_value	s48_set_channel_os_index(s48_value, long);
+extern s48_value	s48_add_channel(s48_value, s48_value, long);
+
+/* external allocation and GC roots */
+extern s48_value	s48_allocate_stob(long type, long size);
+extern void		s48_push_gc_rootsB(char *, long);
+extern char		s48_pop_gc_rootsB(void);
+extern char *		s48_set_gc_roots_baseB(void);
+extern char		s48_release_gc_roots_baseB(char *);
+extern void		s48_register_gc_rootB(char *marker);
diff --git a/c/sysdep.h.in b/c/sysdep.h.in
new file mode 100644
index 0000000..5cbb90e
--- /dev/null
+++ b/c/sysdep.h.in
@@ -0,0 +1,99 @@
+/* c/sysdep.h.in.  Generated automatically from configure.in by autoheader.  */
+
+/* Define to empty if the keyword does not work.  */
+#undef const
+
+/* Define if you need to in order for stat and other things to work.  */
+#undef _POSIX_SOURCE
+
+/* Define as the return type of signal handlers (int or void).  */
+#undef RETSIGTYPE
+
+/*
+ * HAVE_SIGACTION is defined iff sigaction() is available.
+ */
+#undef	HAVE_SIGACTION
+
+/*
+ * HAVE_STRERROR is defined iff the standard libraries provide strerror().
+ */
+#undef	HAVE_STRERROR
+
+/*
+ * NLIST_HAS_N_NAME is defined iff a struct nlist has an n_name member.
+ * If it doesn't then we assume it has an n_un member which, in turn,
+ * has an n_name member.
+ */
+#undef	NLIST_HAS_N_NAME
+
+/*
+ * USCORE is defined iff C externals are prepended with an underscore.
+ */
+#undef	USCORE
+
+/* Define if you have the chroot function.  */
+#undef HAVE_CHROOT
+
+/* Define if you have the dlopen function.  */
+#undef HAVE_DLOPEN
+
+/* Define if you have the ftime function.  */
+#undef HAVE_FTIME
+
+/* Define if you have the gettimeofday function.  */
+#undef HAVE_GETTIMEOFDAY
+
+/* Define if you have the nlist function.  */
+#undef HAVE_NLIST
+
+/* Define if you have the select function.  */
+#undef HAVE_SELECT
+
+/* Define if you have the setitimer function.  */
+#undef HAVE_SETITIMER
+
+/* Define if you have the sigaction function.  */
+#undef HAVE_SIGACTION
+
+/* Define if you have the socket function.  */
+#undef HAVE_SOCKET
+
+/* Define if you have the <libgen.h> header file.  */
+#undef HAVE_LIBGEN_H
+
+/* Define if you have the <posix/time.h> header file.  */
+#undef HAVE_POSIX_TIME_H
+
+/* Define if you have the <sys/select.h> header file.  */
+#undef HAVE_SYS_SELECT_H
+
+/* Define if you have the <sys/timeb.h> header file.  */
+#undef HAVE_SYS_TIMEB_H
+
+/* Define if you have the dl library (-ldl).  */
+#undef HAVE_LIBDL
+
+/* Define if you have the elf library (-lelf).  */
+#undef HAVE_LIBELF
+
+/* Define if you have the gen library (-lgen).  */
+#undef HAVE_LIBGEN
+
+/* Define if you have the m library (-lm).  */
+#undef HAVE_LIBM
+
+/* Define if you have the mld library (-lmld).  */
+#undef HAVE_LIBMLD
+
+/* Define if you have the nsl library (-lnsl).  */
+#undef HAVE_LIBNSL
+
+/* Define if you have the socket library (-lsocket).  */
+#undef HAVE_LIBSOCKET
+
+/* Define if you have the sun library (-lsun).  */
+#undef HAVE_LIBSUN
+
+#include "fake/sigact.h"
+#include "fake/strerror.h"
+#include "fake/sys-select.h"
diff --git a/c/unix/dynamo-test.c b/c/unix/dynamo-test.c
new file mode 100644
index 0000000..70beb8b
--- /dev/null
+++ b/c/unix/dynamo-test.c
@@ -0,0 +1,40 @@
+
+/*
+ * A simple test file for dynamic loading, dynamic name lookup, and
+ * old-style external calls.
+ */
+
+#include <stdio.h>
+#include "scheme48.h"
+
+/*
+ * These should only be called on characters or other immediates.
+ */
+
+s48_value
+s48_dynamo_test(s48_value arg0, s48_value arg1, s48_value arg2)
+{
+  int i;
+
+  s48_value vector = s48_make_vector(3, S48_FALSE);
+
+  S48_VECTOR_SET(vector, 0, arg0);
+  S48_VECTOR_SET(vector, 1, arg1);
+  S48_VECTOR_SET(vector, 2, arg2);
+
+  return vector;
+}
+
+s48_value
+s48_old_dynamo_test(long nargs, s48_value args[])
+{
+  int i;
+
+  s48_value vector = s48_make_vector(nargs, S48_FALSE);
+
+  for (i = 0; i < nargs; i++)
+    S48_VECTOR_SET(vector, i, args[i]);
+
+  return vector;
+}
+
diff --git a/c/unix/dynamo.c b/c/unix/dynamo.c
new file mode 100644
index 0000000..937688b
--- /dev/null
+++ b/c/unix/dynamo.c
@@ -0,0 +1,185 @@
+/*
+ * Lookup external names in the running scheme virtual machine and, on
+ * machines which support it, do dynamic loading.
+ */
+
+#include <stdlib.h>
+#include <unistd.h>
+#include "sysdep.h"
+#include "scheme48.h"
+#include <dlfcn.h>
+
+
+#if	defined(RTLD_NOW)
+#define	DLOPEN_MODE	RTLD_NOW
+#elif	defined(RTLD_LAZY)
+#define	DLOPEN_MODE	(RTLD_LAZY)
+#else
+#define	DLOPEN_MODE	(1)
+#endif
+
+#define	bool		char		/* boolean type */
+#define	TRUE		(0 == 0)
+#define	FALSE		(! TRUE)
+
+
+/*
+ * Linked list of dynamically loaded libraries.
+ */
+static struct	dlob {
+	struct dlob	*next;
+	char		*name;
+	void		*handle;
+}	*dlobs;
+
+
+static s48_value	s48_external_lookup(s48_value svname, s48_value svlocp),
+			s48_old_external_call(s48_value svproc, s48_value svargv),
+			s48_dynamic_load(s48_value filename);
+static long		lookup_external_name(char *name, long *locp);
+static bool		dynamic_load(char *name);
+
+
+/*
+ * Install all exported functions in Scheme48.
+ */
+void
+s48_init_external_lookup(void)
+{
+	S48_EXPORT_FUNCTION(s48_external_lookup);
+	S48_EXPORT_FUNCTION(s48_old_external_call);
+	S48_EXPORT_FUNCTION(s48_dynamic_load);
+}
+
+
+/*
+ * Glue between Scheme48 types and C types for external name lookup.
+ * Look up svname (either in a dynamically loaded library, or in the
+ * running executable).
+ * On success we return TRUE, having set *(long *)svlocp to the location.
+ * On failure, we return FALSE.
+ */
+static s48_value
+s48_external_lookup(s48_value svname, s48_value svlocp)
+{
+	char	*name;
+	long	*locp,
+		res;
+
+	name = s48_extract_string(svname);
+	locp = S48_EXTRACT_VALUE_POINTER(svlocp, long);
+	res = lookup_external_name(name, locp);
+	return (S48_ENTER_BOOLEAN(res));
+}
+
+
+/*
+ * Glue between Scheme48 types and C types for external call.
+ * svproc is a byte vector containing the procedure and svargs is a
+ * vector of arguments.
+ */
+static s48_value
+s48_old_external_call(s48_value svproc, s48_value svargv)
+{
+	s48_value	(*func)();
+	long		*argv,
+			argc;
+
+	func = (s48_value (*)())*S48_EXTRACT_VALUE_POINTER(svproc, long);
+	argc = S48_VECTOR_LENGTH(svargv);
+	argv = S48_ADDRESS_AFTER_HEADER(svargv, long);
+	return (func(argc, argv));
+}
+
+
+/*
+ * Lookup an external name (either in a dynamically loaded library, or
+ * in the running executable).
+ * On success we return TRUE, having set *(long *)locp to the location.
+ * On failure, we return FALSE.
+ */
+static long
+lookup_external_name(char *name, long *locp)
+{
+	struct dlob	*dp;
+	void		*res;
+	static void	*self;
+
+	for (dp = dlobs; dp != NULL; dp = dp->next) {
+		res = dlsym(dp->handle, name);
+		if (dlerror() == NULL) {
+			*locp = (long)res;
+			return (TRUE);
+		}
+	}
+	if (self == NULL) {
+		self = dlopen((char *)NULL, DLOPEN_MODE);
+		if (dlerror() != NULL)
+			return (FALSE);
+	}
+	res = dlsym(self, name);
+	if (dlerror() == NULL) {
+		*locp = (long)res;
+		return (TRUE);
+	}
+	return (FALSE);
+}
+
+
+/*
+ * External to load a library.
+ * Raises an exception if the file cannot be loaded, or loaded properly.
+ * Note, if you load the same file a second time, afterwards you must
+ * evaluate (lookup-all-externals) in package externals to update any
+ * externals the pointed to the old version of the library.
+ */
+
+s48_value
+s48_dynamic_load(s48_value filename)
+{
+	S48_CHECK_STRING(filename);
+
+	if (! dynamic_load(S48_UNSAFE_EXTRACT_STRING(filename)))
+	  /* the cast below is to remove the const part of the type */
+	  s48_raise_string_os_error((char *)dlerror());
+
+	return S48_UNSPECIFIC;
+}
+
+
+static bool
+dynamic_load(char *name)
+{
+	struct dlob	**dpp,
+			*dp;
+	void		*handle;
+
+	for (dpp = &dlobs;; dpp = &dp->next) {
+		dp = *dpp;
+		if (dp == NULL) {
+			handle = dlopen(name, DLOPEN_MODE);
+			if (handle == NULL)
+				return (FALSE);
+			dp = (struct dlob *)malloc(sizeof(*dp) + strlen(name) + 1);
+			if (dp == NULL) {
+				dlclose(handle);
+				return (FALSE);
+			}
+			dp->next = dlobs;
+			dlobs = dp;
+			dp->name = (char *)(dp + 1);
+			strcpy(dp->name, name);
+			dp->handle = handle;
+			return (TRUE);
+		} else if (strcmp(name, dp->name) == 0) {
+			dlclose(dp->handle);
+			dp->handle = dlopen(name, DLOPEN_MODE);
+			if (dp->handle == NULL) {
+				*dpp = dp->next;
+				free((void *)dp);
+				return (FALSE);
+			}
+			return (TRUE);
+		}
+	}
+}
diff --git a/c/unix/event.c b/c/unix/event.c
new file mode 100644
index 0000000..79b16b9
--- /dev/null
+++ b/c/unix/event.c
@@ -0,0 +1,589 @@
+/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
+   See file COPYING. */
+
+#include <signal.h>		/* for sigaction() (POSIX.1) */
+#include <stdlib.h>
+#include <unistd.h>
+#include <stdio.h>
+#include <sys/types.h>
+#include <sys/time.h>
+#include <sys/times.h>
+#include <errno.h>              /* for errno, (POSIX?/ANSI) */
+#include "sysdep.h"
+#include "c-mods.h"
+#include "scheme48vm.h"
+#include "event.h"
+
+/* turning interrupts and I/O readiness into events */
+
+#define block_interrupts()
+#define allow_interrupts()
+
+
+static void	when_keyboard_interrupt();
+static void	when_alarm_interrupt();
+static void     when_sigpipe_interrupt();
+bool		s48_setcatcher(int signum, void (*catcher)(int));
+void		s48_start_alarm_interrupts(void);
+
+
+void
+s48_sysdep_init(void)
+{
+  if (!s48_setcatcher(SIGINT, when_keyboard_interrupt)
+      || !s48_setcatcher(SIGALRM, when_alarm_interrupt)
+      || !s48_setcatcher(SIGPIPE, when_sigpipe_interrupt)) {
+    fprintf(stderr,
+	    "Failed to install signal handlers, errno = %d\n",
+	    errno);
+    exit(1);
+  }
+  s48_start_alarm_interrupts();
+}
+
+
+/*
+ * Unless a signal is being ignored, set up the handler.
+ * If we return FALSE, something went wrong and errno is set to what.
+ */
+bool
+s48_setcatcher(int signum, void (*catcher)(int))
+{
+  struct sigaction	sa;
+
+  if (sigaction(signum, (struct sigaction *)NULL, &sa) != 0)
+    return (FALSE);
+  if (sa.sa_handler == SIG_IGN)
+    return (TRUE);
+  sa.sa_handler = catcher;
+  sigemptyset(&sa.sa_mask);
+  sa.sa_flags = 0;
+  if (sigaction(signum, &sa, (struct sigaction *)NULL) != 0)
+    return (FALSE);
+  return (TRUE);
+}
+
+static long	keyboard_interrupt_count = 0;
+
+static void
+when_keyboard_interrupt(int ign)
+{
+  keyboard_interrupt_count += 1;
+  NOTE_EVENT;
+  return;
+}
+
+/*
+   We turn off SIGPIPE interrupts by installing a handler that does nothing.
+   Turning them off affects exec()'ed programs, so we don't want to do that.
+   Any actual pipe problems are caught when we try to read or write to them.
+
+   We thank Olin Shivers for this hack.
+*/
+
+static void
+when_sigpipe_interrupt(int ign)
+{
+  return;
+}
+
+/* ticks since last timer-interrupt request */
+long		s48_current_time = 0;
+
+static long	alarm_time = -1;
+static long	poll_time = -1;
+static long	poll_interval = 5;
+
+static void
+when_alarm_interrupt(int ign)
+{
+  s48_current_time += 1;
+  /* fprintf(stderr, "[tick]"); */
+  if ((alarm_time >= 0 && alarm_time <= s48_current_time) ||
+      (poll_time >= 0 && poll_time <= s48_current_time)) {
+    NOTE_EVENT;
+  };
+  return;
+}
+
+#define USEC_PER_POLL   (1000000 / POLLS_PER_SECOND)
+
+/* delta is in ticks, 0 cancels current alarm */
+
+long
+s48_schedule_alarm_interrupt(long delta)
+{
+  long old;
+  /*
+  fprintf(stderr, "<scheduling alarm for %ld + %ld>\n", s48_current_time,
+	  delta/TICKS_PER_POLL);
+	  */
+  /* get remaining time */
+  if (alarm_time == -1)
+    old = -1;
+  else
+    old = (alarm_time - s48_current_time) * TICKS_PER_POLL;
+
+  /* decrement poll_time and reset current_time */
+  if (poll_time != -1)
+    poll_time -= s48_current_time;
+  s48_current_time = 0;
+
+  /* set alarm_time */
+  if (delta == 0) {
+    NOTE_EVENT;
+    alarm_time = 0; }
+  else
+    alarm_time = delta / TICKS_PER_POLL;
+
+  return old;
+}
+
+/* The next two procedures return times in seconds and ticks */
+
+long
+s48_real_time(long *ticks)
+{
+  struct timeval tv;
+  static struct timeval tv_orig;
+  static int initp = 0;
+  if (!initp) {
+    gettimeofday(&tv_orig, NULL);
+    initp = 1;
+  };
+  gettimeofday(&tv, NULL);
+  *ticks = (tv.tv_usec - tv_orig.tv_usec)/(1000000/TICKS_PER_SECOND);
+  return tv.tv_sec - tv_orig.tv_sec;
+}
+
+long
+s48_run_time(long *ticks)
+{
+  struct tms time_buffer;
+  static long clock_tick = 0;
+  long cpu_time;
+
+  if (clock_tick == 0)
+    clock_tick = sysconf(_SC_CLK_TCK); /* POSIX.1, POSIX.2 */
+  times(&time_buffer);		/* On Sun, getrusage() would be better */
+
+  cpu_time = time_buffer.tms_utime + time_buffer.tms_stime;
+
+  *ticks = (cpu_time % clock_tick) * TICKS_PER_SECOND / clock_tick;
+  return cpu_time / clock_tick;
+}
+
+void
+s48_start_alarm_interrupts(void)
+{
+  struct itimerval new, old;
+
+  new.it_value.tv_sec = 0;
+  new.it_value.tv_usec = USEC_PER_POLL;
+  new.it_interval.tv_sec = 0;
+  new.it_interval.tv_usec = USEC_PER_POLL;
+  if (0 != setitimer(ITIMER_REAL, &new, &old)) {
+    perror("setitimer");
+    exit(-1); }
+}
+
+void
+s48_stop_alarm_interrupts(void)
+{
+  struct itimerval new, old;
+
+  new.it_value.tv_sec = 0;
+  new.it_value.tv_usec = 0;
+  new.it_interval.tv_sec = 0;
+  new.it_interval.tv_usec = 0;
+  if (0 != setitimer(ITIMER_REAL, &new, &old)) {
+    perror("setitimer");
+    exit(-1); }
+}
+
+
+/*
+ *  ; Scheme version of the get-next-event procedure
+ *  ;
+ *  ; 1. If there has been a keyboard interrupt, return it.
+ *  ; 2. Check for ready ports if enough time has passed since the last check.
+ *  ; 3. If there is a ready port, return it.
+ *  ; 4. If an alarm is due, return it.
+ *  ; 5. If no events are pending, clear the event flags.
+ *  (define (get-next-event)
+ *    (cond ((> *keyboard-interrupt-count* 0)
+ *           (without-interrupts
+ *             (lambda ()
+ *              (set! *keyboard-interrupt-count*
+ *                    (- *keyboard-interrupt-count* 1))))
+ *           (values (enum event-type keyboard-interrupt) #f #f))
+ *          (else
+ *           (cond ((>= *current_time* *poll-time*)
+ *                  (queue-ready-ports)
+ *                  (set! *poll-time* (+ *time* *poll-interval*))))
+ *           (cond ((not (queue-empty? ready-ports))
+ *                  (values (enum event-type i/o-completion)
+ *                          (dequeue! ready-ports)))
+ *                 ((>= *current_time* *alarm-time*)
+ *                  (set! *alarm-time* max-integer)
+ *                  (values (enum event-type alarm-interrupt) #f))
+ *                 (else
+ *                  (without-interrupts
+ *                    (lambda ()
+ *                      (if (and (= *keyboard-interrupt-count* 0)
+ *                               (> *alarm-time* *current_time*)
+ *                               (> *poll-time* *current_time*))
+ *                          (set! *pending-event?* #f))))
+ *                  (values (enum event-type no-event) #f))))))
+ */
+
+static bool	there_are_ready_ports(void);
+static int	next_ready_port(void);
+static int	queue_ready_ports(bool wait, long seconds, long ticks);
+
+int
+s48_get_next_event(long *ready_fd, long *status)
+{
+  /*
+  extern int s48_os_signal_pending(void);
+  */
+
+  int io_poll_status;
+  /*
+    fprintf(stderr, "[poll at %d (waiting for %d)]\n", s48_current_time, alarm_time);
+    */
+  if (keyboard_interrupt_count > 0) {
+    block_interrupts();
+    --keyboard_interrupt_count;
+    allow_interrupts();
+    /* fprintf(stderr, "[keyboard interrupt]\n"); */
+    return (KEYBOARD_INTERRUPT_EVENT);
+  }
+  if (poll_time != -1 && s48_current_time >= poll_time) {
+    io_poll_status = queue_ready_ports(FALSE, 0, 0);
+    if (io_poll_status == NO_ERRORS)
+      poll_time = s48_current_time + poll_interval;
+    else {
+      *status = io_poll_status;
+      return (ERROR_EVENT);
+    }
+  }
+  if (there_are_ready_ports()) {
+    *ready_fd = next_ready_port();
+    *status = 0;   /* chars read or written */
+    /* fprintf(stderr, "[i/o completion]\n"); */
+    return (IO_COMPLETION_EVENT);
+  }
+  if (alarm_time != -1 && s48_current_time >= alarm_time) {
+    alarm_time = -1;
+    /* fprintf(stderr, "[alarm]\n"); */
+    return (ALARM_EVENT);
+  }
+  /*
+  if (s48_os_signal_pending())
+    return (OS_SIGNAL_EVENT);
+    */
+  block_interrupts();
+  if ((keyboard_interrupt_count == 0)
+      &&  (alarm_time == -1 || s48_current_time < alarm_time)
+      &&  (poll_time == -1 || s48_current_time < poll_time))
+    s48_Spending_eventsPS = FALSE;
+  allow_interrupts();
+  return (NO_EVENT);
+}
+
+
+/*
+ * We keep two queues of ports: those that have a pending operation, and
+ * those whose operation has completed.  Periodically, we call select() on
+ * the pending ports and move any that are ready onto the other queue and
+ * signal an event.
+ */
+#define FD_QUIESCENT 0			/* idle */
+#define FD_READY     1			/* I/O ready to be performed */
+#define FD_PENDING   2			/* waiting */
+
+typedef struct fd_struct {
+ int	fd,			/* file descriptor */
+	status;			/* one of the FD_* constants */
+ bool	is_input;		/* iff input */
+ struct fd_struct	*next;	/* next on same queue */
+} fd_struct;
+
+
+/*
+ * A queue of fd_structs is empty iff the first field is NULL.  In
+ * that case, lastp points to first.
+ */
+typedef struct fdque {
+  fd_struct	*first,
+		**lastp;
+} fdque;
+
+
+static fd_struct	*fds[FD_SETSIZE];
+static fdque	ready = {
+			 NULL,
+			 &ready.first
+			},
+		pending = {
+			   NULL,
+			   &pending.first
+			  };
+
+
+static void		findrm(fd_struct *entry, fdque *que);
+static fd_struct	*rmque(fd_struct **link, fdque *que);
+static void		addque(fd_struct *entry, fdque *que);
+static fd_struct	*add_fd(int fd, bool is_input);
+
+
+/*
+ * Find a fd_struct in a queue, and remove it.
+ */
+static void
+findrm(fd_struct *entry, fdque *que)
+{
+  fd_struct	**fp,
+    *f;
+
+  for (fp = &que->first; (f = *fp) != entry; fp = &f->next)
+    if (f == NULL) {
+      fprintf(stderr, "ERROR: findrm fd %d, status %d not on queue.\n",
+	      entry->fd, entry->status);
+      return;
+    }
+  rmque(fp, que);
+}
+
+
+/*
+ * Given a pointer to the link of a fd_struct, and a pointer to
+ * the queue it is on, remove the entry from the queue.
+ * The entry removed is returned.
+ */
+static fd_struct	*
+rmque(fd_struct **link, fdque *que)
+{
+  fd_struct	*res;
+
+  res = *link;
+  *link = res->next;
+  if (res->next == NULL)
+    que->lastp = link;
+  return (res);
+}
+
+
+/*
+ * Add a fd_struct to a queue.
+ */
+static void
+addque(fd_struct *entry, fdque *que)
+{
+  *que->lastp = entry;
+  entry->next = NULL;
+  que->lastp = &entry->next;
+}
+
+
+static bool
+there_are_ready_ports(void)
+{
+  return (ready.first != NULL);
+}
+
+
+static int
+next_ready_port(void)
+{
+  fd_struct	*p;
+
+  p = rmque(&ready.first, &ready);
+  p->status = FD_QUIESCENT;
+  return (p->fd);
+}
+
+
+/*
+ * Put fd on to the queue of ports with pending operations.
+ * Return TRUE if successful, and FALSE otherwise.
+ */
+bool
+s48_add_pending_fd(int fd, bool is_input)
+{
+  fd_struct	*data;
+
+  if (! (0 <= fd && fd < FD_SETSIZE)) {
+    fprintf(stderr, "ERROR: add_pending fd %d not in [0, %d)\n",
+	    fd,
+	    FD_SETSIZE);
+    return (FALSE);
+  }
+  data = fds[fd];
+  if (data == NULL) {
+    data = add_fd(fd, is_input);
+    if (data == NULL)
+      return (FALSE);		/* no more memory */
+  } else if (data->status == FD_PENDING)
+    return (TRUE);			/* fd is already pending */
+  else if (data->status == FD_READY)
+    findrm(data, &ready);
+  data->status = FD_PENDING;
+  addque(data, &pending);
+  if (poll_time == -1)
+    poll_time = s48_current_time + poll_interval;
+  return TRUE;
+}
+
+
+/*
+ * Add a new fd_struct for fd.
+ */
+static fd_struct	*
+add_fd(int fd, bool is_input)
+{
+  struct fd_struct	*new;
+
+  new = (struct fd_struct *)malloc(sizeof(*new));
+  if (new != NULL) {
+    new->fd = fd;
+    new->status = FD_QUIESCENT;
+    new->is_input = is_input;
+    new->next = NULL;
+    fds[fd] = new;
+  }
+  return (new);
+}
+
+
+/*
+ * Remove fd from any queues it is on.  Returns true if the FD was on a queue
+ * and false if it wasn't.
+ */
+bool
+s48_remove_fd(int fd)
+{
+  struct fd_struct	*data;
+
+  if (! (0 <= fd && fd < FD_SETSIZE)) {
+    fprintf(stderr, "ERROR: s48_remove_fd fd %d not in [0, %d)\n",
+	    fd,
+	    FD_SETSIZE);
+    return FALSE;
+  }
+  data = fds[fd];
+  if (data == NULL)
+    return FALSE;
+  if (data->status == FD_PENDING) {
+    findrm(data, &pending);
+    if (pending.first == NULL)
+      poll_time = -1;
+  } else if (data->status == FD_READY)
+    findrm(data, &ready);
+  free((void *)data);
+  fds[fd] = NULL;
+  return TRUE;
+}
+
+
+int
+s48_wait_for_event(long max_wait, bool is_minutes)
+{
+  int	status;
+  long	seconds,
+	ticks;
+
+  /* fprintf(stderr, "[waiting]\n"); */
+
+  s48_stop_alarm_interrupts();
+  ticks = 0;
+  if (max_wait == -1)
+    seconds = -1;
+  else if (is_minutes)
+    seconds = max_wait * 60;
+  else {
+    seconds = max_wait / TICKS_PER_SECOND;
+    ticks = max_wait % TICKS_PER_SECOND;
+  }
+  if (keyboard_interrupt_count > 0)
+    status = NO_ERRORS;
+  else {
+    status = queue_ready_ports(TRUE, seconds, ticks);
+    if (there_are_ready_ports())
+      NOTE_EVENT;
+  }
+  s48_start_alarm_interrupts();
+  return (status);
+}
+
+
+/*
+ * Call select() on the pending ports and move any ready ones to the ready
+ * queue.  If wait is true, seconds is either -1 (wait forever) or the
+ * maximum number of seconds to wait (with ticks any additional ticks).
+ * The returned value is a status code.
+ */
+static int
+queue_ready_ports(bool wait, long seconds, long ticks)
+{
+  fd_set	reads,
+    		writes,
+    		alls;
+  int		limfd;
+  fd_struct	*fdp,
+    		**fdpp;
+  int		left;
+  struct timeval	tv,
+    			*tvp;
+
+  if ((! wait)
+      &&  (pending.first == NULL))
+    return (NO_ERRORS);
+  FD_ZERO(&reads);
+  FD_ZERO(&writes);
+  FD_ZERO(&alls);
+  limfd = 0;
+  for (fdp = pending.first; fdp != NULL; fdp = fdp->next) {
+    FD_SET(fdp->fd, fdp->is_input ? &reads : &writes);
+    FD_SET(fdp->fd, &alls);
+    if (limfd <= fdp->fd)
+      limfd = fdp->fd + 1;
+  }
+  tvp = &tv;
+  if (wait)
+    if (seconds == -1)
+      tvp = NULL;
+    else {
+      tv.tv_sec = seconds;
+      tv.tv_usec = ticks * (1000000 / TICKS_PER_SECOND);
+    }
+  else
+    timerclear(&tv);
+  while(TRUE) {
+    left = select(limfd, &reads, &writes, &alls, tvp);
+    if (left > 0) {
+      fdpp = &pending.first;
+      while (left > 0 && (fdp = *fdpp) != NULL)
+	if ((FD_ISSET(fdp->fd, &alls))
+	    ||  (FD_ISSET(fdp->fd, fdp->is_input ? &reads : &writes))) {
+	  --left;
+	  rmque(fdpp, &pending);
+	  fdp->status = FD_READY;
+	  addque(fdp, &ready);
+	} else
+	  fdpp = &fdp->next;
+      if (pending.first == NULL)
+	poll_time = -1;
+      return NO_ERRORS;
+    }
+    else if (left == 0)
+      return NO_ERRORS;
+    else if (errno == EINTR) {
+      tvp = &tv;		/* turn off blocking and try again */
+      timerclear(tvp);
+    }	      
+    else
+      return errno;
+  }
+}
diff --git a/c/unix/fd-io.c b/c/unix/fd-io.c
new file mode 100644
index 0000000..ff8df92
--- /dev/null
+++ b/c/unix/fd-io.c
@@ -0,0 +1,181 @@
+/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
+   See file COPYING. */
+
+#include <unistd.h>
+#include <stdio.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <sys/time.h>
+#include <errno.h>              /* for errno, (POSIX?/ANSI) */
+#include "sysdep.h"
+#include "c-mods.h"
+#include "scheme48vm.h"
+#include "event.h"
+
+
+/* Non-blocking I/O on file descriptors.
+
+ There appear to be two ways to get non-blocking input and output.  One
+ is to open files with the O_NONBLOCK flag (and to use fcntl() to do the
+ same to stdin and stdout), the other is to call select() on each file
+ descriptor before doing the I/O operation.  O_NONBLOCK has the problem
+ of being a property of the file descriptor, and its use with stdin and
+ stdout can lead to horrible results.
+
+ We use a mixture of both.  For input files we call select() before doing
+ a read(), because read() will return immediately if there are any bytes
+ available at all, and using O_NONBLOCK on stdin is a very bad idea.
+ Output files are opened using O_NONBLOCK and stdout is left alone.
+
+*/
+
+int
+ps_open_fd(char *filename, bool is_input, long *status)
+{
+#define FILE_NAME_SIZE 1024
+#define PERMISSION 0666   /* read and write for everyone */
+
+  char filename_temp[FILE_NAME_SIZE];
+  char *expanded;
+  extern char *s48_expand_file_name(char *, char *, int);
+
+  int flags;
+  mode_t mode;
+
+  expanded = s48_expand_file_name(filename, filename_temp, FILE_NAME_SIZE);
+  if (expanded == NULL)
+    return -1;
+
+  if (is_input) {
+    flags = O_RDONLY;
+    mode = 0; }
+  else {
+    flags = O_WRONLY | O_CREAT | O_TRUNC | O_NONBLOCK;
+    mode = PERMISSION; }
+
+  /* keep trying if interrupted */
+  while(TRUE) {
+    int fd = open(expanded, flags, mode);
+    if (fd != -1) {
+      *status = NO_ERRORS;
+      return fd; }
+    else if (errno != EINTR) {
+      *status = errno;
+      return -1; }
+  }
+}
+
+int
+ps_close_fd(long fd_as_long)
+{
+  int fd = (int)fd_as_long;
+
+  /* keep retrying if interrupted */
+  while(TRUE) {
+    int status = close(fd);
+    if (status != -1) {
+      s48_remove_fd(fd);
+      return NO_ERRORS; }
+    else if (errno != EINTR)
+      return errno;
+  }
+}
+
+long
+ps_read_fd(long fd_as_long, char *buffer, long max, bool waitp,
+	   bool *eofp, bool *pending, long *status)
+{
+  int got, ready;
+  void *buf = (void *)buffer;
+  int fd = (int)fd_as_long;
+
+  struct timeval timeout;
+  fd_set readfds;
+
+  FD_ZERO(&readfds);
+  FD_SET(fd, &readfds);
+  timerclear(&timeout);
+
+  /* for the normal return */
+  *eofp = FALSE;
+  *pending = FALSE;
+  *status = NO_ERRORS;
+
+  while(TRUE) {
+    ready = select(fd + 1, &readfds, NULL, &readfds, &timeout);
+    if (ready == 0) {
+      if (!waitp)
+	return 0;
+      else if (s48_add_pending_fd(fd, TRUE)) {
+	*pending = TRUE;
+	return 0; }
+      else {
+	*status = ENOMEM;    /* as close as POSIX gets */
+	return 0; }}
+    else if (ready == -1) {
+      if (errno != EINTR) {
+	*status = errno;
+	return 0; } }
+    else {          /* characters waiting */
+
+      got = read(fd, buf, max);
+
+      if (got > 0) {       /* all is well */
+	return got; }
+      else if (got == 0) { /* end of file */
+	*eofp = TRUE;
+	return 0; }
+      else if (errno == EINTR) {			/* HCC */
+	return 0; }
+      else if (errno == EAGAIN) {			/* HCC */
+	if (!waitp)
+	  return 0;
+	else if (s48_add_pending_fd(fd, TRUE)) {
+	  *pending = TRUE;
+	  return 0; }
+	else {
+	  *status = ENOMEM;    /* as close as POSIX gets */
+	  return 0; } }
+      else {
+	*status = errno;
+	return 0; } } }
+}
+
+long
+ps_write_fd(long fd_as_long, char *buffer, long max, bool *pending, long *status)
+{
+  int sent;
+  int fd = (int)fd_as_long;
+  void *buf = (void *)buffer;
+
+  *pending = FALSE;
+  *status = NO_ERRORS;
+
+  sent = write(fd, buf, max);
+  if (sent > 0)
+    {}
+  else if (errno == EINTR || errno == EAGAIN) {		/* HCC */
+    if (s48_add_pending_fd(fd, FALSE))
+      *pending = TRUE;
+    else
+      *status = ENOMEM;    /* as close as POSIX gets */
+    sent = 0; }
+  else {
+    *status = errno;
+    sent = 0; }
+
+  return sent;
+}
+
+long
+ps_abort_fd_op(long fd_as_long)
+{
+  int fd = (int)fd_as_long;
+
+  if (!s48_remove_fd(fd))
+    fprintf(stderr, "Error: ps_abort_fd_op, no pending operation on fd %d\n",
+	            fd);
+  return 0;      /* because we do not actually do any I/O in parallel the
+		    status is always zero: no characters transfered. */
+}
diff --git a/c/unix/io.c b/c/unix/io.c
new file mode 100644
index 0000000..ed21219
--- /dev/null
+++ b/c/unix/io.c
@@ -0,0 +1,296 @@
+/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
+   See file COPYING. */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <errno.h>
+#include <stdarg.h>
+#include <string.h>
+#include "io.h"
+#include "scheme48.h"
+
+#define	TRUE	(0 == 0)
+#define	FALSE	(! TRUE)
+#define	bool	char
+
+/* read a character while ignoring interrupts */
+
+#define READ_CHAR(PORT,RESULT)				\
+{							\
+  FILE * TTport = PORT;					\
+  int TTchar;						\
+  if (EOF == (TTchar = getc(TTport)))			\
+    RESULT = s48_read_char(TTport);			\
+  else							\
+    RESULT = TTchar; 					\
+}
+
+/*
+Helper procedure for the READ_CHAR macro.  If the getc was interrupted
+we clear the error bit and try again.
+*/
+
+int
+s48_read_char(FILE *port)
+{
+  int result;
+
+  while(TRUE) {
+    if (ferror(port) && errno == EINTR) {
+      clearerr(port);
+      result = getc(port);
+      if (EOF != result)
+	return result; }
+    else
+      return EOF; }
+}
+
+/* called when getc(port) returned EOF */
+
+char
+ps_read_char(FILE *port, bool *eofp, long *status, bool peekp)
+{
+  bool errorp;
+  int result;
+
+  result = s48_read_char(port);     /* read past any interruptions */
+  if (result != EOF) {
+    if (peekp)
+      ungetc(result, port);
+    *eofp = FALSE;
+    *status = NO_ERRORS;
+    return result; }
+  else {
+    errorp = ferror(port);
+    clearerr(port);
+    if (errorp) {
+      *eofp = FALSE;
+      *status = errno;
+      return 0; }
+    else {
+      *eofp = TRUE;
+      *status = NO_ERRORS;
+      return 0; } }
+}
+
+long
+ps_read_integer(FILE *port, bool *eofp, long *status)
+{
+  long result;
+  int ch;
+  bool negate;
+  bool errorp;
+
+  /* eat whitespace */
+  do { READ_CHAR(port, ch); }
+  while (ch == ' ' || ch == '\t' || ch == '\n');
+
+  /* read optional sign */
+  if (ch == '-') {
+    negate = TRUE;
+    READ_CHAR(port, ch); }
+  else
+    negate = FALSE;
+
+  if (ch < '0' || '9' < ch) {
+    if (ch != EOF) {
+      *eofp = FALSE;
+      *status = EINVAL; }  /* has to be something */
+    else {
+      errorp = ferror(port);
+      clearerr(port);
+      if (errorp) {
+	*eofp = FALSE;
+	*status = errno; }
+      else {
+	*eofp = TRUE;
+	*status = 0; } }
+    result = 0; }
+  else {
+    result = ch - '0';
+    while(1) {
+      READ_CHAR(port, ch);
+      if (ch < '0' || '9' < ch)
+	break;
+      result = (10 * result) + (ch - '0'); }
+    if (ch != EOF)
+      ungetc(ch, port);
+    *eofp = FALSE;
+    *status = 0; }
+  return (negate ? -result : result);
+}
+
+/* write a character regardless of interrupts */
+
+#define WRITE_CHAR(CH,PORT,RESULT)			\
+{							\
+  char TTch = CH;					\
+  FILE * TTport = PORT;					\
+  if (putc(TTch, TTport) != EOF)			\
+    RESULT = 0;						\
+  else							\
+    RESULT = ps_write_char(TTch, TTport);		\
+}
+
+/* called when putc(char, port) returned EOF */
+
+long
+ps_write_char(char ch, FILE *port)
+{
+
+  while(TRUE) {
+    clearerr(port);
+    if (errno != EINTR)
+      return errno;
+    else if (putc(ch, port) != EOF)
+      return 0; }
+}
+
+long
+ps_write_integer(long n, FILE *port)
+{
+  int status;
+
+  static long write_integer(unsigned long n, FILE *port);
+
+  if (n == 0) {
+    WRITE_CHAR('0', port, status);
+    return status; }
+  else if (n > 0)
+    return write_integer(n, port);
+  else {
+    WRITE_CHAR('-', port, status);
+    if (status == 0)
+      return write_integer(- n, port);
+    else
+      return status; }
+}
+
+static long
+write_integer(unsigned long n, FILE *port)
+{
+  char ch;
+  long status;
+
+  if (n == 0)
+    status = 0;
+  else {
+    status = write_integer(n / 10, port);
+    if (status == 0) {
+      ch = (n % 10) + '0';
+      WRITE_CHAR(ch, port,status); } }
+  return status;
+}
+
+long
+ps_write_string(char *string, FILE *port)
+{
+	while (TRUE) {
+		if (EOF != fputs(string, port))
+			return (0);
+		clearerr(port);
+		if (errno != EINTR)
+			return (errno);
+	}
+}
+
+long
+ps_read_block(FILE *port, char *buffer, long count, bool *eofp, long *status)
+{
+  int got = 0;
+  bool errorp;
+
+  while(TRUE) {
+    got += fread(buffer, sizeof(char), count - got, port);
+    if (got == count) {
+      *eofp = FALSE;
+      *status = NO_ERRORS;
+      return got;}
+    else if (ferror(port) && errno == EINTR)
+      clearerr(port);
+    else {
+      *eofp = feof(port);
+      errorp = ferror(port);
+      clearerr(port);
+      if (errorp)
+	*status = errno;
+      else
+	*status = NO_ERRORS;
+      return got;} };
+}
+
+long
+ps_write_block(FILE *port, char *buffer, long count)
+{
+  int sent = 0;
+
+  while(TRUE) {
+    sent += fwrite(buffer, sizeof(char), count - sent, port);
+    if (sent == count)
+      return NO_ERRORS;
+    else if (ferror(port) && errno == EINTR)
+      clearerr(port);
+    else {
+      clearerr(port);
+      return errno; } }
+}
+
+void
+ps_error(char *message, long count, ...)
+{
+  va_list ap;
+
+  va_start(ap, count);
+  fputs(message, stderr);
+  for(; count > 0; --count)
+    fprintf(stderr, " %ld", va_arg(ap, long));
+  putc('\n', stderr);
+  exit(-1);
+}
+
+static FILE *
+ps_really_open_file(char *filename, long *status, char *mode)
+{
+#define FILE_NAME_SIZE 1024
+
+  char filename_temp[FILE_NAME_SIZE];
+  char *expanded;
+  extern char *s48_expand_file_name(char *, char *, int);
+
+  FILE *new;
+
+  expanded = s48_expand_file_name(filename, filename_temp, FILE_NAME_SIZE);
+  if (expanded == NULL) {
+    *status = EDOM;    /* has to be something */
+    return NULL; }
+
+  new = fopen(expanded, mode);
+
+  if (new == NULL) {
+    *status = errno;
+    return NULL; }
+
+  *status = NO_ERRORS;
+  return new;
+}
+
+FILE *
+ps_open_input_file(char *name, long *status)
+{
+  return ps_really_open_file(name, status, "r");
+}
+
+FILE *
+ps_open_output_file(char *name, long *status)
+{
+  return ps_really_open_file(name, status, "w");
+}
+
+long
+ps_close(FILE *stream)
+{
+  if (0 == fclose(stream))
+    return 0;
+  else
+    return errno;
+}
diff --git a/c/unix/misc.c b/c/unix/misc.c
new file mode 100644
index 0000000..f8fe75e
--- /dev/null
+++ b/c/unix/misc.c
@@ -0,0 +1,129 @@
+/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
+   See file COPYING. */
+
+#include <stdio.h>
+#include <stdlib.h>		/* for getenv(), etc. (POSIX?/ANSI) */
+#include <string.h>		/* for strncpy(), etc. (POSIX/ANSI) */
+#include <pwd.h>		/* for getpwnam() (POSIX.1) */
+#include <unistd.h>		/* for sysconf(), etc.  (POSIX.1/.2)*/
+#include <errno.h>
+#include "sysdep.h"
+
+
+#define TRUE  (0 == 0)
+#define FALSE (0 == 1)
+
+/*
+   Expanding Unix filenames
+   Unix Sucks
+   Richard Kelsey Wed Jan 17 21:40:26 EST 1990
+   Later modified by others who wish to remain anonymous
+
+   Expands initial ~ and ~/ in string `name', leaving the result in `buffer'.
+   `buffer_len' is the length of `buffer'.
+
+   Note: strncpy(x, y, n) copies from y to x.
+*/
+
+char *s48_expand_file_name (name, buffer, buffer_len)
+  char *name, *buffer;
+  int buffer_len;
+{
+#define USER_NAME_SIZE 256
+  char *dir, *p, user_name[USER_NAME_SIZE];
+  struct passwd *user_data;
+  int dir_len, i;
+  extern char *getenv();
+  int name_len = strlen(name);
+
+  dir = 0;
+
+  if (name[0] == '~') {
+    name++; name_len--;
+
+    if (name[0] == '/' || name[0] == 0) {
+      dir = getenv("HOME"); }
+
+    else {
+      for (i = 0, p = name; i < name_len && *p != '/'; i++, p++)
+	if (i > (USER_NAME_SIZE - 2)) {
+	  fprintf(stderr,
+		  "\ns48_expand_file_name: user name longer than %d characters\n",
+		  USER_NAME_SIZE - 3);
+	  return(NULL); };
+      strncpy(user_name, name, i);
+      user_name[i] = 0;
+      user_data = getpwnam(user_name);
+      if (!user_data) {
+	fprintf(stderr, "\ns48_expand_file_name: unknown user \"%s\"\n",
+		user_name);
+	return(NULL); };
+      name_len -= i;
+      name = p;
+      dir = user_data->pw_dir; } }
+
+  else if (name[0] == '$') {
+    name++; name_len--;
+
+    for (i = 0, p = name; i < name_len && *p != '/'; i++, p++)
+      if (i > (USER_NAME_SIZE - 2)) {
+	fprintf(stderr,
+		"\ns48_expand_file_name: environment variable longer than %d characters\n",
+		USER_NAME_SIZE - 3);
+	return(NULL); };
+    strncpy(user_name, name, i);
+    user_name[i] = 0;
+
+    name_len -= i;
+    name = p;
+    dir = getenv(user_name); }
+
+  if (dir) {
+    dir_len = strlen(dir);
+    if ((name_len + dir_len + 1) > buffer_len) {
+      fprintf(stderr, "\ns48_expand_file_name: supplied buffer is too small\n");
+      return(NULL); };
+    strncpy(buffer, dir, dir_len);
+    strncpy(buffer + dir_len, name, name_len);
+    buffer[name_len + dir_len] = 0; }
+
+  else {
+    if ((name_len + 1) > buffer_len) {
+      fprintf(stderr, "\ns48_expand_file_name: supplied buffer is too small\n");
+      return(NULL); };
+    strncpy(buffer, name, name_len);
+    buffer[name_len] = 0; }
+
+  return(buffer);
+}
+
+/* test routine
+main(argc, argv)
+  int argc;
+  char *argv[];
+{
+  char buffer[32];
+  s48_expand_file_name(argv[1], buffer, 32);
+  printf("%s\n", buffer);
+  return(0);
+}
+*/
+
+
+/* Driver loop for tail-recursive calls */
+
+long s48_return_value;
+
+long
+s48_run_machine(long (*proc) (void))
+{
+  while (proc != 0)
+    proc = (long (*) (void)) (*proc)();
+  return s48_return_value;
+}
+
+unsigned char *
+ps_error_string(long the_errno)
+{
+  return((unsigned char *)strerror(the_errno));
+}
diff --git a/c/unix/socket.c b/c/unix/socket.c
new file mode 100644
index 0000000..b8946a4
--- /dev/null
+++ b/c/unix/socket.c
@@ -0,0 +1,376 @@
+/* Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees.
+   See file COPYING. */
+
+/*
+ * An interface to Unix sockets.
+ */
+
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <sys/param.h>
+#include <errno.h>
+#include <fcntl.h>
+#include <netdb.h>
+#include <unistd.h>
+#include <string.h>
+#include <netinet/in.h>
+
+#include "c-mods.h"
+#include "scheme48.h"
+#include "fd-io.h"		/* ps_close_fd() */
+#include "event.h"		/* add_pending_fd() */
+
+/* Henry Cejtin says that 5 is the largest safe number for this. */
+#define	LISTEN_QUEUE_SIZE	5
+
+extern void		s48_init_socket(void);
+static s48_value	s48_socket(s48_value server_p),
+			s48_bind(s48_value socket_channel, s48_value number),
+			s48_socket_number(s48_value socket_channel),
+			s48_listen(s48_value socket_channel),
+			s48_accept(s48_value socket_channel),
+			s48_connect(s48_value socket_channel,
+				    s48_value machine,
+				    s48_value port),
+			s48_close_socket_half(s48_value socket_channel,
+					      s48_value input_p),
+			s48_get_host_name(void);
+
+/*
+ * Install all exported functions in Scheme48.
+ */
+void
+s48_init_socket(void)
+{
+  S48_EXPORT_FUNCTION(s48_socket);
+  S48_EXPORT_FUNCTION(s48_bind);
+  S48_EXPORT_FUNCTION(s48_socket_number);
+  S48_EXPORT_FUNCTION(s48_listen);
+  S48_EXPORT_FUNCTION(s48_accept);
+  S48_EXPORT_FUNCTION(s48_connect);
+  S48_EXPORT_FUNCTION(s48_close_socket_half);
+  S48_EXPORT_FUNCTION(s48_get_host_name);
+}
+
+/*
+ * Create an internet-domain stream (reliable, sequenced) socket.
+ * We return an input channel on success and raise an exception on failure.
+ * The socket has been made non-blocking.
+ */
+
+static s48_value
+s48_socket(s48_value server_p)
+{
+  int		fd,
+    		mode;
+  s48_value	channel;
+
+  fd = socket(AF_INET, SOCK_STREAM, 0);
+
+  if (fd < 0)
+    s48_raise_os_error(errno);
+
+  if (-1 == fcntl(fd, F_SETFL, O_NONBLOCK))
+    s48_raise_os_error(errno);
+
+  mode = (server_p == S48_FALSE) ?
+    S48_CHANNEL_STATUS_SPECIAL_OUTPUT :
+    S48_CHANNEL_STATUS_SPECIAL_INPUT;
+
+  channel = s48_add_channel(mode, s48_enter_string("socket"), fd);
+
+  if (!S48_CHANNEL_P(channel)) {
+    ps_close_fd(fd);		/* retries if interrupted */
+    s48_raise_scheme_exception(s48_extract_fixnum(channel), 0); };
+
+  return channel;
+}
+
+/*
+ * Given an internet-domain stream socket and a port number, bind
+ * the socket to the port and prepare to receive connections.
+ * If the port number is #f, then we bind the socket to any available
+ * port.
+ * 
+ * Nothing useful is returned.
+ */
+
+static s48_value
+s48_bind(s48_value channel, s48_value port_number)
+{
+  int			socket_fd,
+			port;
+  struct sockaddr_in	address;
+
+  S48_CHECK_CHANNEL(channel);
+  socket_fd = S48_UNSAFE_EXTRACT_FIXNUM(S48_UNSAFE_CHANNEL_OS_INDEX(channel));
+
+  if (port_number == S48_FALSE)
+    port = 0;
+  else
+    port = s48_extract_fixnum(port_number);
+
+  address.sin_family = AF_INET;
+  address.sin_addr.s_addr = htonl(INADDR_ANY);
+  address.sin_port = htons(port);
+
+  if (bind(socket_fd, (struct sockaddr *)&address, sizeof(address)) < 0)
+    s48_raise_os_error(errno);
+
+  return S48_UNSPECIFIC;
+}
+
+/*
+ * Return the port number associated with an internet stream socket.
+ */
+
+static s48_value
+s48_socket_number(s48_value channel)
+{
+  int			socket_fd,
+			len;
+  struct sockaddr_in	address;
+
+  S48_CHECK_CHANNEL(channel);
+  socket_fd = S48_UNSAFE_EXTRACT_FIXNUM(S48_UNSAFE_CHANNEL_OS_INDEX(channel));
+
+  address.sin_addr.s_addr = htonl(INADDR_ANY);
+
+  len = sizeof(address);
+
+  if ((getsockname(socket_fd, (struct sockaddr *)&address, &len) < 0)
+	|| (address.sin_family != AF_INET))
+    s48_raise_os_error(errno);
+
+  return s48_enter_fixnum(htons(address.sin_port));
+}
+
+static s48_value
+s48_listen(s48_value channel)
+{
+  int			socket_fd;
+
+  S48_CHECK_CHANNEL(channel);
+  socket_fd = S48_UNSAFE_EXTRACT_FIXNUM(S48_UNSAFE_CHANNEL_OS_INDEX(channel));
+
+  if (listen(socket_fd, LISTEN_QUEUE_SIZE) < 0)
+    s48_raise_os_error(errno);
+
+  return S48_UNSPECIFIC;
+}
+
+
+/*
+ * Given an internet-domain stream socket which has been bound
+ * accept a connection and return the resulting socket as a pair of channels
+ * (after marking it non-blocking).
+ *
+ * If the accept fails because the client hasn't connected yet, then we
+ * return #f.
+ *
+ * If it fails for any other reason, then an exception is raised.
+ */
+
+static s48_value
+s48_accept(s48_value channel)
+{
+  int			socket_fd,
+   			connect_fd,
+			output_fd,
+			len;
+  struct sockaddr_in	address;
+  s48_value		input_channel,
+			output_channel;
+
+  S48_CHECK_CHANNEL(channel);
+  socket_fd = S48_UNSAFE_EXTRACT_FIXNUM(S48_UNSAFE_CHANNEL_OS_INDEX(channel));
+
+  len = sizeof(address);
+  connect_fd = accept(socket_fd, (struct sockaddr *)&address, &len);
+  
+  /*
+   * Check for a connection.  If we have one we create two channels, one
+   * input and one, with a dup()'ed fd, output.  Lots of error checking
+   * makes this messy.
+   */
+
+  if (connect_fd >= 0) {
+    
+    S48_DECLARE_GC_PROTECT(1);
+  
+    if (-1 == fcntl(connect_fd, F_SETFL, O_NONBLOCK))
+      s48_raise_os_error(errno);
+
+    input_channel = s48_add_channel(S48_CHANNEL_STATUS_INPUT,
+				    s48_enter_string("socket connection"),
+				    connect_fd);
+
+    if (!S48_CHANNEL_P(input_channel)) {
+      ps_close_fd(connect_fd);		/* retries if interrupted */
+      s48_raise_scheme_exception(s48_extract_fixnum(input_channel), 0); };
+    
+    output_fd = dup(connect_fd);
+
+    if (output_fd == -1)
+      s48_raise_os_error(errno);
+
+    S48_GC_PROTECT_1(input_channel);
+  
+    output_channel = s48_add_channel(S48_CHANNEL_STATUS_OUTPUT,
+				     s48_enter_string("socket connection"),
+				     output_fd);
+    
+    if (!S48_CHANNEL_P(output_channel)) {
+      /* input_channel will eventually be closed by the GC */
+      ps_close_fd(output_fd);		/* retries if interrupted */
+      s48_raise_scheme_exception(s48_extract_fixnum(output_channel), 0); };
+    
+    S48_GC_UNPROTECT();
+
+    return s48_cons(input_channel, output_channel);
+  }
+
+  /*
+   * Check for errors.  If we need to retry we mark the socket as pending
+   * and return #F to tell the Scheme procedure to wait.
+   */
+
+  if ((errno != EWOULDBLOCK) && (errno != EINTR) && (errno == EAGAIN))
+    s48_raise_os_error(errno);
+
+  if (! s48_add_pending_fd(socket_fd, TRUE))
+    s48_raise_out_of_memory_error();
+
+  return S48_FALSE;
+}
+
+/*
+ * Given an internet-domain stream socket, a machine name and a port number,
+ * connect the socket to that machine/port.
+ *
+ * If this succeeds, it returns an output channel for the connection.
+ * If it fails because the connect would block, add the socket to the
+ * pending queue (for output) and return #f.
+ * If it fails for any other reason, raise an exception.
+ */
+
+static s48_value
+s48_connect(s48_value channel, s48_value machine, s48_value port)
+{
+  int			socket_fd,
+			output_fd,
+    			port_number;
+  char			*machine_name;
+  struct hostent	*host;
+  struct sockaddr_in	address;
+  s48_value		output_channel;
+
+  S48_CHECK_CHANNEL(channel);
+  socket_fd = S48_UNSAFE_EXTRACT_FIXNUM(S48_UNSAFE_CHANNEL_OS_INDEX(channel));
+
+  S48_CHECK_STRING(machine);
+  machine_name = S48_UNSAFE_EXTRACT_STRING(machine);
+  
+  S48_CHECK_FIXNUM(port);
+  port_number = S48_UNSAFE_EXTRACT_FIXNUM(port);
+  
+  /*
+   * Get the host and initialize `address'.
+   */
+
+  host = gethostbyname(machine_name);
+  if (host == NULL)
+    s48_raise_os_error(errno);
+  
+  memset((void *)&address, 0, sizeof(address));
+  address.sin_family = host->h_addrtype;
+
+  if (host->h_length > sizeof(address.sin_addr))
+    s48_raise_range_error(s48_enter_fixnum(host->h_length),
+			  S48_UNSAFE_ENTER_FIXNUM(0),
+			  s48_enter_fixnum(sizeof(address.sin_addr)));
+  memcpy((void *)&address.sin_addr, (void *)host->h_addr, host->h_length);
+  address.sin_port = htons(port_number);
+
+  /*
+   * Try the connection.  If it works we make an output channel and return it.
+   * The original socket channel will be used as the input channel.
+   */
+
+  if (connect(socket_fd, (struct sockaddr *)&address, sizeof(address)) >= 0) {
+    S48_STOB_SET(channel, S48_CHANNEL_STATUS_OFFSET, S48_CHANNEL_STATUS_INPUT);
+    
+    output_fd = dup(socket_fd);
+    
+    if (output_fd == -1)
+      s48_raise_os_error(errno);
+    
+    output_channel = s48_add_channel(S48_CHANNEL_STATUS_OUTPUT,
+				     s48_enter_string("socket connection"),
+				     output_fd);
+    
+    if (!S48_CHANNEL_P(output_channel)) {
+      ps_close_fd(output_fd);		/* retries if interrupted */
+      s48_raise_scheme_exception(s48_extract_fixnum(output_channel), 0); };
+    
+    return output_channel;
+  }
+
+  /*
+   * Check for errors.  If we need to retry we mark the socket as pending
+   * and return #F to tell the Scheme procedure to wait.
+   */
+
+  /* already connected, will raise an error from Scheme */
+  if (errno == EISCONN)
+    return S48_TRUE;
+
+  if (errno != EWOULDBLOCK && errno != EINTR && errno != EALREADY
+      && errno != EINPROGRESS && errno != EAGAIN)
+    s48_raise_os_error(errno);
+
+  if (! (s48_add_pending_fd(socket_fd, FALSE)))
+    s48_raise_out_of_memory_error();
+
+  return S48_FALSE;
+}
+
+/*
+ * Close half of a socket; if `input_p' is true we close the input half,
+ * otherwise the output half.  This horribleness is forced upon us by
+ * Unix's use of bidirectional file descriptors.
+ */
+
+static s48_value
+s48_close_socket_half(s48_value channel, s48_value input_p)
+{
+  int	socket_fd;
+
+  S48_CHECK_CHANNEL(channel);
+  socket_fd = S48_UNSAFE_EXTRACT_FIXNUM(S48_UNSAFE_CHANNEL_OS_INDEX(channel));
+
+  /* We ignore `endpoint is not connected' errors, as we just want to get
+     the file descriptor closed. */
+  if ((0 > shutdown(socket_fd, S48_EXTRACT_BOOLEAN(input_p) ? 0 : 1))
+      && (errno != ENOTCONN))
+    s48_raise_os_error(errno);
+  
+  return S48_TRUE;
+}  
+
+
+/*
+ * Get the name of the local machine.
+ */
+
+static s48_value
+s48_get_host_name(void)
+{
+  char	mbuff[MAXHOSTNAMELEN];
+
+  if (gethostname(mbuff, sizeof(mbuff)) < 0)
+    s48_raise_os_error(errno);
+  
+  return s48_enter_string(mbuff);
+}
+
diff --git a/c/unix/test.c b/c/unix/test.c
new file mode 100644
index 0000000..0835635
--- /dev/null
+++ b/c/unix/test.c
@@ -0,0 +1,12 @@
+
+#include "c/scheme48.h"
+
+long
+frog(long arg_count, long *args)
+{
+  long i, res;
+
+  for (i = 0, res = s48_enter_integer(-100); i < arg_count; res += args[i], i++);
+
+  return res;
+}
diff --git a/c/write-barrier.h b/c/write-barrier.h
new file mode 100644
index 0000000..721b011
--- /dev/null
+++ b/c/write-barrier.h
@@ -0,0 +1,2 @@
+
+#define	S48_WRITE_BARRIER(stob, address, value)	((void)0)
diff --git a/configure b/configure
new file mode 100755
index 0000000..be73f2e
--- /dev/null
+++ b/configure
@@ -0,0 +1,1925 @@
+#! /bin/sh
+
+# Guess values for system-dependent variables and create Makefiles.
+# Generated automatically using autoconf version 2.10 
+# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc.
+#
+# This configure script is free software; the Free Software Foundation
+# gives unlimited permission to copy, distribute and modify it.
+
+# Defaults:
+ac_help=
+ac_default_prefix=/usr/local
+# Any additions from configure.in:
+
+# Initialize some variables set by options.
+# The variables have the same names as the options, with
+# dashes changed to underlines.
+build=NONE
+cache_file=./config.cache
+exec_prefix=NONE
+host=NONE
+no_create=
+nonopt=NONE
+no_recursion=
+prefix=NONE
+program_prefix=NONE
+program_suffix=NONE
+program_transform_name=s,x,x,
+silent=
+site=
+srcdir=
+target=NONE
+verbose=
+x_includes=NONE
+x_libraries=NONE
+bindir='${exec_prefix}/bin'
+sbindir='${exec_prefix}/sbin'
+libexecdir='${exec_prefix}/libexec'
+datadir='${prefix}/share'
+sysconfdir='${prefix}/etc'
+sharedstatedir='${prefix}/com'
+localstatedir='${prefix}/var'
+libdir='${exec_prefix}/lib'
+includedir='${prefix}/include'
+oldincludedir='/usr/include'
+infodir='${prefix}/info'
+mandir='${prefix}/man'
+
+# Initialize some other variables.
+subdirs=
+MFLAGS= MAKEFLAGS=
+
+ac_prev=
+for ac_option
+do
+
+  # If the previous option needs an argument, assign it.
+  if test -n "$ac_prev"; then
+    eval "$ac_prev=\$ac_option"
+    ac_prev=
+    continue
+  fi
+
+  case "$ac_option" in
+  -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;;
+  *) ac_optarg= ;;
+  esac
+
+  # Accept the important Cygnus configure options, so we can diagnose typos.
+
+  case "$ac_option" in
+
+  -bindir | --bindir | --bindi | --bind | --bin | --bi)
+    ac_prev=bindir ;;
+  -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)
+    bindir="$ac_optarg" ;;
+
+  -build | --build | --buil | --bui | --bu)
+    ac_prev=build ;;
+  -build=* | --build=* | --buil=* | --bui=* | --bu=*)
+    build="$ac_optarg" ;;
+
+  -cache-file | --cache-file | --cache-fil | --cache-fi \
+  | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c)
+    ac_prev=cache_file ;;
+  -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \
+  | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)
+    cache_file="$ac_optarg" ;;
+
+  -datadir | --datadir | --datadi | --datad | --data | --dat | --da)
+    ac_prev=datadir ;;
+  -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \
+  | --da=*)
+    datadir="$ac_optarg" ;;
+
+  -disable-* | --disable-*)
+    ac_feature=`echo $ac_option|sed -e 's/-*disable-//'`
+    # Reject names that are not valid shell variable names.
+    if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then
+      { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; }
+    fi
+    ac_feature=`echo $ac_feature| sed 's/-/_/g'`
+    eval "enable_${ac_feature}=no" ;;
+
+  -enable-* | --enable-*)
+    ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'`
+    # Reject names that are not valid shell variable names.
+    if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then
+      { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; }
+    fi
+    ac_feature=`echo $ac_feature| sed 's/-/_/g'`
+    case "$ac_option" in
+      *=*) ;;
+      *) ac_optarg=yes ;;
+    esac
+    eval "enable_${ac_feature}='$ac_optarg'" ;;
+
+  -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \
+  | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \
+  | --exec | --exe | --ex)
+    ac_prev=exec_prefix ;;
+  -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \
+  | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \
+  | --exec=* | --exe=* | --ex=*)
+    exec_prefix="$ac_optarg" ;;
+
+  -gas | --gas | --ga | --g)
+    # Obsolete; use --with-gas.
+    with_gas=yes ;;
+
+  -help | --help | --hel | --he)
+    # Omit some internal or obsolete options to make the list less imposing.
+    # This message is too long to be a string in the A/UX 3.1 sh.
+    cat << EOF
+Usage: configure [options] [host]
+Options: [defaults in brackets after descriptions]
+Configuration:
+  --cache-file=FILE       cache test results in FILE
+  --help                  print this message
+  --no-create             do not create output files
+  --quiet, --silent       do not print \`checking...' messages
+  --version               print the version of autoconf that created configure
+Directory and file names:
+  --prefix=PREFIX         install architecture-independent files in PREFIX
+                          [$ac_default_prefix]
+  --exec-prefix=EPREFIX   install architecture-dependent files in EPREFIX
+                          [same as prefix]
+  --bindir=DIR            user executables in DIR [EPREFIX/bin]
+  --sbindir=DIR           system admin executables in DIR [EPREFIX/sbin]
+  --libexecdir=DIR        program executables in DIR [EPREFIX/libexec]
+  --datadir=DIR           read-only architecture-independent data in DIR
+                          [PREFIX/share]
+  --sysconfdir=DIR        read-only single-machine data in DIR [PREFIX/etc]
+  --sharedstatedir=DIR    modifiable architecture-independent data in DIR
+                          [PREFIX/com]
+  --localstatedir=DIR     modifiable single-machine data in DIR [PREFIX/var]
+  --libdir=DIR            object code libraries in DIR [EPREFIX/lib]
+  --includedir=DIR        C header files in DIR [PREFIX/include]
+  --oldincludedir=DIR     C header files for non-gcc in DIR [/usr/include]
+  --infodir=DIR           info documentation in DIR [PREFIX/info]
+  --mandir=DIR            man documentation in DIR [PREFIX/man]
+  --srcdir=DIR            find the sources in DIR [configure dir or ..]
+  --program-prefix=PREFIX prepend PREFIX to installed program names
+  --program-suffix=SUFFIX append SUFFIX to installed program names
+  --program-transform-name=PROGRAM
+                          run sed PROGRAM on installed program names
+EOF
+    cat << EOF
+Host type:
+  --build=BUILD           configure for building on BUILD [BUILD=HOST]
+  --host=HOST             configure for HOST [guessed]
+  --target=TARGET         configure for TARGET [TARGET=HOST]
+Features and packages:
+  --disable-FEATURE       do not include FEATURE (same as --enable-FEATURE=no)
+  --enable-FEATURE[=ARG]  include FEATURE [ARG=yes]
+  --with-PACKAGE[=ARG]    use PACKAGE [ARG=yes]
+  --without-PACKAGE       do not use PACKAGE (same as --with-PACKAGE=no)
+  --x-includes=DIR        X include files are in DIR
+  --x-libraries=DIR       X library files are in DIR
+EOF
+    if test -n "$ac_help"; then
+      echo "--enable and --with options recognized:$ac_help"
+    fi
+    exit 0 ;;
+
+  -host | --host | --hos | --ho)
+    ac_prev=host ;;
+  -host=* | --host=* | --hos=* | --ho=*)
+    host="$ac_optarg" ;;
+
+  -includedir | --includedir | --includedi | --included | --include \
+  | --includ | --inclu | --incl | --inc)
+    ac_prev=includedir ;;
+  -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \
+  | --includ=* | --inclu=* | --incl=* | --inc=*)
+    includedir="$ac_optarg" ;;
+
+  -infodir | --infodir | --infodi | --infod | --info | --inf)
+    ac_prev=infodir ;;
+  -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*)
+    infodir="$ac_optarg" ;;
+
+  -libdir | --libdir | --libdi | --libd)
+    ac_prev=libdir ;;
+  -libdir=* | --libdir=* | --libdi=* | --libd=*)
+    libdir="$ac_optarg" ;;
+
+  -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \
+  | --libexe | --libex | --libe)
+    ac_prev=libexecdir ;;
+  -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \
+  | --libexe=* | --libex=* | --libe=*)
+    libexecdir="$ac_optarg" ;;
+
+  -localstatedir | --localstatedir | --localstatedi | --localstated \
+  | --localstate | --localstat | --localsta | --localst \
+  | --locals | --local | --loca | --loc | --lo)
+    ac_prev=localstatedir ;;
+  -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \
+  | --localstate=* | --localstat=* | --localsta=* | --localst=* \
+  | --locals=* | --local=* | --loca=* | --loc=* | --lo=*)
+    localstatedir="$ac_optarg" ;;
+
+  -mandir | --mandir | --mandi | --mand | --man | --ma | --m)
+    ac_prev=mandir ;;
+  -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*)
+    mandir="$ac_optarg" ;;
+
+  -nfp | --nfp | --nf)
+    # Obsolete; use --without-fp.
+    with_fp=no ;;
+
+  -no-create | --no-create | --no-creat | --no-crea | --no-cre \
+  | --no-cr | --no-c)
+    no_create=yes ;;
+
+  -no-recursion | --no-recursion | --no-recursio | --no-recursi \
+  | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r)
+    no_recursion=yes ;;
+
+  -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \
+  | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \
+  | --oldin | --oldi | --old | --ol | --o)
+    ac_prev=oldincludedir ;;
+  -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \
+  | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \
+  | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*)
+    oldincludedir="$ac_optarg" ;;
+
+  -prefix | --prefix | --prefi | --pref | --pre | --pr | --p)
+    ac_prev=prefix ;;
+  -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)
+    prefix="$ac_optarg" ;;
+
+  -program-prefix | --program-prefix | --program-prefi | --program-pref \
+  | --program-pre | --program-pr | --program-p)
+    ac_prev=program_prefix ;;
+  -program-prefix=* | --program-prefix=* | --program-prefi=* \
+  | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*)
+    program_prefix="$ac_optarg" ;;
+
+  -program-suffix | --program-suffix | --program-suffi | --program-suff \
+  | --program-suf | --program-su | --program-s)
+    ac_prev=program_suffix ;;
+  -program-suffix=* | --program-suffix=* | --program-suffi=* \
+  | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*)
+    program_suffix="$ac_optarg" ;;
+
+  -program-transform-name | --program-transform-name \
+  | --program-transform-nam | --program-transform-na \
+  | --program-transform-n | --program-transform- \
+  | --program-transform | --program-transfor \
+  | --program-transfo | --program-transf \
+  | --program-trans | --program-tran \
+  | --progr-tra | --program-tr | --program-t)
+    ac_prev=program_transform_name ;;
+  -program-transform-name=* | --program-transform-name=* \
+  | --program-transform-nam=* | --program-transform-na=* \
+  | --program-transform-n=* | --program-transform-=* \
+  | --program-transform=* | --program-transfor=* \
+  | --program-transfo=* | --program-transf=* \
+  | --program-trans=* | --program-tran=* \
+  | --progr-tra=* | --program-tr=* | --program-t=*)
+    program_transform_name="$ac_optarg" ;;
+
+  -q | -quiet | --quiet | --quie | --qui | --qu | --q \
+  | -silent | --silent | --silen | --sile | --sil)
+    silent=yes ;;
+
+  -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
+    ac_prev=sbindir ;;
+  -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
+  | --sbi=* | --sb=*)
+    sbindir="$ac_optarg" ;;
+
+  -sharedstatedir | --sharedstatedir | --sharedstatedi \
+  | --sharedstated | --sharedstate | --sharedstat | --sharedsta \
+  | --sharedst | --shareds | --shared | --share | --shar \
+  | --sha | --sh)
+    ac_prev=sharedstatedir ;;
+  -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \
+  | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \
+  | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \
+  | --sha=* | --sh=*)
+    sharedstatedir="$ac_optarg" ;;
+
+  -site | --site | --sit)
+    ac_prev=site ;;
+  -site=* | --site=* | --sit=*)
+    site="$ac_optarg" ;;
+
+  -srcdir | --srcdir | --srcdi | --srcd | --src | --sr)
+    ac_prev=srcdir ;;
+  -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*)
+    srcdir="$ac_optarg" ;;
+
+  -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \
+  | --syscon | --sysco | --sysc | --sys | --sy)
+    ac_prev=sysconfdir ;;
+  -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \
+  | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*)
+    sysconfdir="$ac_optarg" ;;
+
+  -target | --target | --targe | --targ | --tar | --ta | --t)
+    ac_prev=target ;;
+  -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*)
+    target="$ac_optarg" ;;
+
+  -v | -verbose | --verbose | --verbos | --verbo | --verb)
+    verbose=yes ;;
+
+  -version | --version | --versio | --versi | --vers)
+    echo "configure generated by autoconf version 2.10"
+    exit 0 ;;
+
+  -with-* | --with-*)
+    ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'`
+    # Reject names that are not valid shell variable names.
+    if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then
+      { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; }
+    fi
+    ac_package=`echo $ac_package| sed 's/-/_/g'`
+    case "$ac_option" in
+      *=*) ;;
+      *) ac_optarg=yes ;;
+    esac
+    eval "with_${ac_package}='$ac_optarg'" ;;
+
+  -without-* | --without-*)
+    ac_package=`echo $ac_option|sed -e 's/-*without-//'`
+    # Reject names that are not valid shell variable names.
+    if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then
+      { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; }
+    fi
+    ac_package=`echo $ac_package| sed 's/-/_/g'`
+    eval "with_${ac_package}=no" ;;
+
+  --x)
+    # Obsolete; use --with-x.
+    with_x=yes ;;
+
+  -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \
+  | --x-incl | --x-inc | --x-in | --x-i)
+    ac_prev=x_includes ;;
+  -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \
+  | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*)
+    x_includes="$ac_optarg" ;;
+
+  -x-libraries | --x-libraries | --x-librarie | --x-librari \
+  | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l)
+    ac_prev=x_libraries ;;
+  -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \
+  | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*)
+    x_libraries="$ac_optarg" ;;
+
+  -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; }
+    ;;
+
+  *)
+    if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then
+      echo "configure: warning: $ac_option: invalid host type" 1>&2
+    fi
+    if test "x$nonopt" != xNONE; then
+      { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; }
+    fi
+    nonopt="$ac_option"
+    ;;
+
+  esac
+done
+
+if test -n "$ac_prev"; then
+  { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; }
+fi
+
+trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15
+
+# File descriptor usage:
+# 0 standard input
+# 1 file creation
+# 2 errors and warnings
+# 3 some systems may open it to /dev/tty
+# 4 used on the Kubota Titan
+# 6 checking for... messages and results
+# 5 compiler messages saved in config.log
+if test "$silent" = yes; then
+  exec 6>/dev/null
+else
+  exec 6>&1
+fi
+exec 5>./config.log
+
+echo "\
+This file contains any messages produced by compilers while
+running configure, to aid debugging if configure makes a mistake.
+" 1>&5
+
+# Strip out --no-create and --no-recursion so they do not pile up.
+# Also quote any args containing shell metacharacters.
+ac_configure_args=
+for ac_arg
+do
+  case "$ac_arg" in
+  -no-create | --no-create | --no-creat | --no-crea | --no-cre \
+  | --no-cr | --no-c) ;;
+  -no-recursion | --no-recursion | --no-recursio | --no-recursi \
+  | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;;
+  *" "*|*"	"*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*)
+  ac_configure_args="$ac_configure_args '$ac_arg'" ;;
+  *) ac_configure_args="$ac_configure_args $ac_arg" ;;
+  esac
+done
+
+# NLS nuisances.
+# Only set LANG and LC_ALL to C if already set.
+# These must not be set unconditionally because not all systems understand
+# e.g. LANG=C (notably SCO).
+if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi
+if test "${LANG+set}"   = set; then LANG=C;   export LANG;   fi
+
+# confdefs.h avoids OS command line length limits that DEFS can exceed.
+rm -rf conftest* confdefs.h
+# AIX cpp loses on an empty file, so make sure it contains at least a newline.
+echo > confdefs.h
+
+# A filename unique to this package, relative to the directory that
+# configure is in, which we can look for to find out if srcdir is correct.
+ac_unique_file=c/scheme48vm.c
+
+# Find the source files, if location was not specified.
+if test -z "$srcdir"; then
+  ac_srcdir_defaulted=yes
+  # Try the directory containing this script, then its parent.
+  ac_prog=$0
+  ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'`
+  test "x$ac_confdir" = "x$ac_prog" && ac_confdir=.
+  srcdir=$ac_confdir
+  if test ! -r $srcdir/$ac_unique_file; then
+    srcdir=..
+  fi
+else
+  ac_srcdir_defaulted=no
+fi
+if test ! -r $srcdir/$ac_unique_file; then
+  if test "$ac_srcdir_defaulted" = yes; then
+    { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; }
+  else
+    { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; }
+  fi
+fi
+srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'`
+
+# Prefer explicitly selected file to automatically selected ones.
+if test -z "$CONFIG_SITE"; then
+  if test "x$prefix" != xNONE; then
+    CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site"
+  else
+    CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site"
+  fi
+fi
+for ac_site_file in $CONFIG_SITE; do
+  if test -r "$ac_site_file"; then
+    echo "loading site script $ac_site_file"
+    . "$ac_site_file"
+  fi
+done
+
+if test -r "$cache_file"; then
+  echo "loading cache $cache_file"
+  . $cache_file
+else
+  echo "creating cache $cache_file"
+  > $cache_file
+fi
+
+ac_ext=c
+# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options.
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5'
+ac_link='${CC-cc} -o conftest $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5'
+
+if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then
+  # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu.
+  if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then
+    ac_n= ac_c='
+' ac_t='	'
+  else
+    ac_n=-n ac_c= ac_t=
+  fi
+else
+  ac_n= ac_c='\c' ac_t=
+fi
+
+
+     
+     	oldCFLAGS="$CFLAGS"
+	# Extract the first word of "gcc", so it can be a program name with args.
+set dummy gcc; ac_word=$2
+echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
+if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  if test -n "$CC"; then
+  ac_cv_prog_CC="$CC" # Let the user override the test.
+else
+  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS="${IFS}:"
+  for ac_dir in $PATH; do
+    test -z "$ac_dir" && ac_dir=.
+    if test -f $ac_dir/$ac_word; then
+      ac_cv_prog_CC="gcc"
+      break
+    fi
+  done
+  IFS="$ac_save_ifs"
+fi
+fi
+CC="$ac_cv_prog_CC"
+if test -n "$CC"; then
+  echo "$ac_t""$CC" 1>&6
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+if test -z "$CC"; then
+  # Extract the first word of "cc", so it can be a program name with args.
+set dummy cc; ac_word=$2
+echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
+if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  if test -n "$CC"; then
+  ac_cv_prog_CC="$CC" # Let the user override the test.
+else
+  IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS="${IFS}:"
+  ac_prog_rejected=no
+  for ac_dir in $PATH; do
+    test -z "$ac_dir" && ac_dir=.
+    if test -f $ac_dir/$ac_word; then
+      if test "$ac_dir/$ac_word" = "/usr/ucb/cc"; then
+        ac_prog_rejected=yes
+	continue
+      fi
+      ac_cv_prog_CC="cc"
+      break
+    fi
+  done
+  IFS="$ac_save_ifs"
+if test $ac_prog_rejected = yes; then
+  # We found a bogon in the path, so make sure we never use it.
+  set dummy $ac_cv_prog_CC
+  shift
+  if test $# -gt 0; then
+    # We chose a different compiler from the bogus one.
+    # However, it has the same basename, so the bogon will be chosen
+    # first if we set CC to just the basename; use the full file name.
+    shift
+    set dummy "$ac_dir/$ac_word" "$@"
+    shift
+    ac_cv_prog_CC="$@"
+  fi
+fi
+fi
+fi
+CC="$ac_cv_prog_CC"
+if test -n "$CC"; then
+  echo "$ac_t""$CC" 1>&6
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+  test -z "$CC" && { echo "configure: error: no acceptable cc found in \$PATH" 1>&2; exit 1; }
+fi
+
+echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6
+if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  cat > conftest.c <<EOF
+#ifdef __GNUC__
+  yes;
+#endif
+EOF
+if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:604: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
+  ac_cv_prog_gcc=yes
+else
+  ac_cv_prog_gcc=no
+fi
+fi
+
+echo "$ac_t""$ac_cv_prog_gcc" 1>&6
+if test $ac_cv_prog_gcc = yes; then
+  GCC=yes
+  if test "${CFLAGS+set}" != set; then
+    echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6
+if eval "test \"`echo '$''{'ac_cv_prog_gcc_g'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  echo 'void f(){}' > conftest.c
+if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then
+  ac_cv_prog_gcc_g=yes
+else
+  ac_cv_prog_gcc_g=no
+fi
+rm -f conftest*
+
+fi
+
+echo "$ac_t""$ac_cv_prog_gcc_g" 1>&6
+    if test $ac_cv_prog_gcc_g = yes; then
+      CFLAGS="-g -O"
+    else
+      CFLAGS="-O"
+    fi
+  fi
+else
+  GCC=
+  test "${CFLAGS+set}" = set || CFLAGS="-g"
+fi
+
+	if test "z$oldCFLAGS" = z; then
+		if test "z$GCC" = z; then
+			CFLAGS='-O'
+		else
+			CFLAGS='-O2'
+		fi
+	fi
+
+     echo $ac_n "checking for POSIXized ISC""... $ac_c" 1>&6
+if test -d /etc/conf/kconfig.d &&
+  grep _POSIX_VERSION /usr/include/sys/unistd.h >/dev/null 2>&1
+then
+  echo "$ac_t""yes" 1>&6
+  ISC=yes # If later tests want to check for ISC.
+  cat >> confdefs.h <<\EOF
+#define _POSIX_SOURCE 1
+EOF
+
+  if test "$GCC" = yes; then
+    CC="$CC -posix"
+  else
+    CC="$CC -Xp"
+  fi
+else
+  echo "$ac_t""no" 1>&6
+  ISC=
+fi
+
+          # If we cannot run a trivial program, we must be cross compiling.
+echo $ac_n "checking whether cross-compiling""... $ac_c" 1>&6
+if eval "test \"`echo '$''{'ac_cv_c_cross'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  if test "$cross_compiling" = yes; then
+  ac_cv_c_cross=yes
+else
+cat > conftest.$ac_ext <<EOF
+#line 678 "configure"
+#include "confdefs.h"
+main(){return(0);}
+EOF
+{ (eval echo configure:682: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }
+if test -s conftest && (./conftest; exit) 2>/dev/null; then
+  ac_cv_c_cross=no
+else
+  ac_cv_c_cross=yes
+fi
+fi
+rm -fr conftest*
+fi
+
+echo "$ac_t""$ac_cv_c_cross" 1>&6
+cross_compiling=$ac_cv_c_cross
+
+if test "$cross_compiling" = yes; then
+  true
+else
+cat > conftest.$ac_ext <<EOF
+#line 699 "configure"
+#include "confdefs.h"
+int main() { return 0;}
+EOF
+{ (eval echo configure:703: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }
+if test -s conftest && (./conftest; exit) 2>/dev/null; then
+  :
+fi
+fi
+rm -fr conftest*
+     	if test "z$GCC" = z; then
+		echo $ac_n "checking -cckr""... $ac_c" 1>&6
+		oldCFLAGS="$CFLAGS"
+		CFLAGS="$CFLAGS -cckr"
+		if test "$cross_compiling" = yes; then
+  echo "$ac_t""no" 1>&6
+				CFLAGS="$oldCFLAGS"
+else
+cat > conftest.$ac_ext <<EOF
+#line 718 "configure"
+#include "confdefs.h"
+int main() { return 0;}
+EOF
+{ (eval echo configure:722: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }
+if test -s conftest && (./conftest; exit) 2>/dev/null; then
+  echo "$ac_t""yes" 1>&6
+else
+  echo "$ac_t""no" 1>&6
+				CFLAGS="$oldCFLAGS"
+fi
+fi
+rm -fr conftest*
+	fi
+
+     ac_aux_dir=
+for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do
+  if test -f $ac_dir/install-sh; then
+    ac_aux_dir=$ac_dir
+    ac_install_sh="$ac_aux_dir/install-sh -c"
+    break
+  elif test -f $ac_dir/install.sh; then
+    ac_aux_dir=$ac_dir
+    ac_install_sh="$ac_aux_dir/install.sh -c"
+    break
+  fi
+done
+if test -z "$ac_aux_dir"; then
+  { echo "configure: error: can not find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." 1>&2; exit 1; }
+fi
+ac_config_guess=$ac_aux_dir/config.guess
+ac_config_sub=$ac_aux_dir/config.sub
+ac_configure=$ac_aux_dir/configure # This should be Cygnus configure.
+
+# Find a good install program.  We prefer a C program (faster),
+# so one script is as good as another.  But avoid the broken or
+# incompatible versions:
+# SysV /etc/install, /usr/sbin/install
+# SunOS /usr/etc/install
+# IRIX /sbin/install
+# AIX /bin/install
+# AFS /usr/afsws/bin/install, which mishandles nonexistent args
+# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff"
+# ./install, which can be erroneously created by make from ./install.sh.
+echo $ac_n "checking for a BSD compatible install""... $ac_c" 1>&6
+if test -z "$INSTALL"; then
+if eval "test \"`echo '$''{'ac_cv_path_install'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+    IFS="${IFS= 	}"; ac_save_ifs="$IFS"; IFS="${IFS}:"
+  for ac_dir in $PATH; do
+    # Account for people who put trailing slashes in PATH elements.
+    case "$ac_dir/" in
+    /|./|.//|/etc/*|/usr/sbin/*|/usr/etc/*|/sbin/*|/usr/afsws/bin/*|/usr/ucb/*) ;;
+    *)
+      # OSF1 and SCO ODT 3.0 have their own names for install.
+      for ac_prog in ginstall installbsd scoinst install; do
+        if test -f $ac_dir/$ac_prog; then
+	  if test $ac_prog = install &&
+            grep dspmsg $ac_dir/$ac_prog >/dev/null 2>&1; then
+	    # AIX install.  It has an incompatible calling convention.
+	    # OSF/1 installbsd also uses dspmsg, but is usable.
+	    :
+	  else
+	    ac_cv_path_install="$ac_dir/$ac_prog -c"
+	    break 2
+	  fi
+	fi
+      done
+      ;;
+    esac
+  done
+  IFS="$ac_save_ifs"
+
+fi
+  if test "${ac_cv_path_install+set}" = set; then
+    INSTALL="$ac_cv_path_install"
+  else
+    # As a last resort, use the slow shell script.  We don't cache a
+    # path for INSTALL within a source directory, because that will
+    # break other packages using the cache if that directory is
+    # removed, or if the path is relative.
+    INSTALL="$ac_install_sh"
+  fi
+fi
+echo "$ac_t""$INSTALL" 1>&6
+
+# Use test -z because SunOS4 sh mishandles braces in ${var-val}.
+# It thinks the first close brace ends the variable substitution.
+test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}'
+
+test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644'
+
+     echo $ac_n "checking for -lm""... $ac_c" 1>&6
+ac_lib_var=`echo m'_'main | tr './+\055' '__p_'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  ac_save_LIBS="$LIBS"
+LIBS="-lm  $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 819 "configure"
+#include "confdefs.h"
+
+int main() { return 0; }
+int t() {
+main()
+; return 0; }
+EOF
+if { (eval echo configure:827: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=yes"
+else
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+    ac_tr_lib=HAVE_LIB`echo m | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'`
+  cat >> confdefs.h <<EOF
+#define $ac_tr_lib 1
+EOF
+
+  LIBS="-lm $LIBS"
+
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+     echo $ac_n "checking for -ldl""... $ac_c" 1>&6
+ac_lib_var=`echo dl'_'main | tr './+\055' '__p_'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  ac_save_LIBS="$LIBS"
+LIBS="-ldl  $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 859 "configure"
+#include "confdefs.h"
+
+int main() { return 0; }
+int t() {
+main()
+; return 0; }
+EOF
+if { (eval echo configure:867: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=yes"
+else
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+    ac_tr_lib=HAVE_LIB`echo dl | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'`
+  cat >> confdefs.h <<EOF
+#define $ac_tr_lib 1
+EOF
+
+  LIBS="-ldl $LIBS"
+
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+     echo $ac_n "checking for -lmld""... $ac_c" 1>&6
+ac_lib_var=`echo mld'_'main | tr './+\055' '__p_'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  ac_save_LIBS="$LIBS"
+LIBS="-lmld  $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 899 "configure"
+#include "confdefs.h"
+
+int main() { return 0; }
+int t() {
+main()
+; return 0; }
+EOF
+if { (eval echo configure:907: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=yes"
+else
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+    ac_tr_lib=HAVE_LIB`echo mld | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'`
+  cat >> confdefs.h <<EOF
+#define $ac_tr_lib 1
+EOF
+
+  LIBS="-lmld $LIBS"
+
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+     echo $ac_n "checking for -lnsl""... $ac_c" 1>&6
+ac_lib_var=`echo nsl'_'main | tr './+\055' '__p_'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  ac_save_LIBS="$LIBS"
+LIBS="-lnsl  $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 939 "configure"
+#include "confdefs.h"
+
+int main() { return 0; }
+int t() {
+main()
+; return 0; }
+EOF
+if { (eval echo configure:947: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=yes"
+else
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+    ac_tr_lib=HAVE_LIB`echo nsl | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'`
+  cat >> confdefs.h <<EOF
+#define $ac_tr_lib 1
+EOF
+
+  LIBS="-lnsl $LIBS"
+
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+     echo $ac_n "checking for -lgen""... $ac_c" 1>&6
+ac_lib_var=`echo gen'_'main | tr './+\055' '__p_'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  ac_save_LIBS="$LIBS"
+LIBS="-lgen  $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 979 "configure"
+#include "confdefs.h"
+
+int main() { return 0; }
+int t() {
+main()
+; return 0; }
+EOF
+if { (eval echo configure:987: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=yes"
+else
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+    ac_tr_lib=HAVE_LIB`echo gen | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'`
+  cat >> confdefs.h <<EOF
+#define $ac_tr_lib 1
+EOF
+
+  LIBS="-lgen $LIBS"
+
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+     echo $ac_n "checking for -lsocket""... $ac_c" 1>&6
+ac_lib_var=`echo socket'_'main | tr './+\055' '__p_'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  ac_save_LIBS="$LIBS"
+LIBS="-lsocket  $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 1019 "configure"
+#include "confdefs.h"
+
+int main() { return 0; }
+int t() {
+main()
+; return 0; }
+EOF
+if { (eval echo configure:1027: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=yes"
+else
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+    ac_tr_lib=HAVE_LIB`echo socket | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'`
+  cat >> confdefs.h <<EOF
+#define $ac_tr_lib 1
+EOF
+
+  LIBS="-lsocket $LIBS"
+
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+     echo $ac_n "checking for -lsun""... $ac_c" 1>&6
+ac_lib_var=`echo sun'_'getpwnam | tr './+\055' '__p_'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  ac_save_LIBS="$LIBS"
+LIBS="-lsun  $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 1059 "configure"
+#include "confdefs.h"
+/* Override any gcc2 internal prototype to avoid an error.  */
+/* We use char because int might match the return type of a gcc2
+    builtin and then its argument prototype would still apply.  */
+char getpwnam();
+
+int main() { return 0; }
+int t() {
+getpwnam()
+; return 0; }
+EOF
+if { (eval echo configure:1071: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=yes"
+else
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+    ac_tr_lib=HAVE_LIB`echo sun | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'`
+  cat >> confdefs.h <<EOF
+#define $ac_tr_lib 1
+EOF
+
+  LIBS="-lsun $LIBS"
+
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+          echo $ac_n "checking for -lelf""... $ac_c" 1>&6
+ac_lib_var=`echo elf'_'main | tr './+\055' '__p_'`
+if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  ac_save_LIBS="$LIBS"
+LIBS="-lelf  $LIBS"
+cat > conftest.$ac_ext <<EOF
+#line 1103 "configure"
+#include "confdefs.h"
+
+int main() { return 0; }
+int t() {
+main()
+; return 0; }
+EOF
+if { (eval echo configure:1111: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=yes"
+else
+  rm -rf conftest*
+  eval "ac_cv_lib_$ac_lib_var=no"
+fi
+rm -f conftest*
+LIBS="$ac_save_LIBS"
+
+fi
+if eval "test \"`echo '$ac_cv_lib_'$ac_lib_var`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+    ac_tr_lib=HAVE_LIB`echo elf | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'`
+  cat >> confdefs.h <<EOF
+#define $ac_tr_lib 1
+EOF
+
+  LIBS="-lelf $LIBS"
+
+else
+  echo "$ac_t""no" 1>&6
+fi
+
+     echo checking for RISC/OS POSIX library lossage
+if test -f /usr/posix/usr/lib/libc.a; then
+  LIBS="${LIBS} /usr/posix/usr/lib/libc.a"
+fi
+
+     echo $ac_n "checking for working const""... $ac_c" 1>&6
+if eval "test \"`echo '$''{'ac_cv_c_const'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  cat > conftest.$ac_ext <<EOF
+#line 1145 "configure"
+#include "confdefs.h"
+
+int main() { return 0; }
+int t() {
+
+/* Ultrix mips cc rejects this.  */
+typedef int charset[2]; const charset x;
+/* SunOS 4.1.1 cc rejects this.  */
+char const *const *ccp;
+char **p;
+/* NEC SVR4.0.2 mips cc rejects this.  */
+struct point {int x, y;};
+static struct point const zero = {0,0};
+/* AIX XL C 1.02.0.0 rejects this.
+   It does not let you subtract one const X* pointer from another in an arm
+   of an if-expression whose if-part is not a constant expression */
+const char *g = "string";
+ccp = &g + (g ? g-g : 0);
+/* HPUX 7.0 cc rejects these. */
+++ccp;
+p = (char**) ccp;
+ccp = (char const *const *) p;
+{ /* SCO 3.2v4 cc rejects this.  */
+  char *t;
+  char const *s = 0 ? (char *) 0 : (char const *) 0;
+
+  *t++ = 0;
+}
+{ /* Someone thinks the Sun supposedly-ANSI compiler will reject this.  */
+  int x[] = {25, 17};
+  const int *foo = &x[0];
+  ++foo;
+}
+{ /* Sun SC1.0 ANSI compiler rejects this -- but not the above. */
+  typedef const int *iptr;
+  iptr p = 0;
+  ++p;
+}
+{ /* AIX XL C 1.02.0.0 rejects this saying
+     "k.c", line 2.27: 1506-025 (S) Operand must be a modifiable lvalue. */
+  struct s { int j; const int *ap[3]; };
+  struct s *b; b->j = 5;
+}
+{ /* ULTRIX-32 V3.1 (Rev 9) vcc rejects this */
+  const int foo = 10;
+}
+
+; return 0; }
+EOF
+if { (eval echo configure:1195: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+  rm -rf conftest*
+  ac_cv_c_const=yes
+else
+  rm -rf conftest*
+  ac_cv_c_const=no
+fi
+rm -f conftest*
+
+fi
+
+echo "$ac_t""$ac_cv_c_const" 1>&6
+if test $ac_cv_c_const = no; then
+  cat >> confdefs.h <<\EOF
+#define const 
+EOF
+
+fi
+
+     echo $ac_n "checking return type of signal handlers""... $ac_c" 1>&6
+if eval "test \"`echo '$''{'ac_cv_type_signal'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  cat > conftest.$ac_ext <<EOF
+#line 1219 "configure"
+#include "confdefs.h"
+#include <sys/types.h>
+#include <signal.h>
+#ifdef signal
+#undef signal
+#endif
+#ifdef __cplusplus
+extern "C" void (*signal (int, void (*)(int)))(int);
+#else
+void (*signal ()) ();
+#endif
+
+int main() { return 0; }
+int t() {
+int i;
+; return 0; }
+EOF
+if { (eval echo configure:1237: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+  rm -rf conftest*
+  ac_cv_type_signal=void
+else
+  rm -rf conftest*
+  ac_cv_type_signal=int
+fi
+rm -f conftest*
+
+fi
+
+echo "$ac_t""$ac_cv_type_signal" 1>&6
+cat >> confdefs.h <<EOF
+#define RETSIGTYPE $ac_cv_type_signal
+EOF
+
+
+     echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6
+# On Suns, sometimes $CPP names a directory.
+if test -n "$CPP" && test -d "$CPP"; then
+  CPP=
+fi
+if test -z "$CPP"; then
+if eval "test \"`echo '$''{'ac_cv_prog_CPP'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+    # This must be in double quotes, not single quotes, because CPP may get
+  # substituted into the Makefile and "${CC-cc}" will confuse make.
+  CPP="${CC-cc} -E"
+  # On the NeXT, cc -E runs the code through the compiler's parser,
+  # not just through cpp.
+  cat > conftest.$ac_ext <<EOF
+#line 1269 "configure"
+#include "confdefs.h"
+#include <assert.h>
+Syntax Error
+EOF
+ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
+{ (eval echo configure:1275: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+ac_err=`grep -v '^ *+' conftest.out`
+if test -z "$ac_err"; then
+  :
+else
+  echo "$ac_err" >&5
+  rm -rf conftest*
+  CPP="${CC-cc} -E -traditional-cpp"
+  cat > conftest.$ac_ext <<EOF
+#line 1284 "configure"
+#include "confdefs.h"
+#include <assert.h>
+Syntax Error
+EOF
+ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
+{ (eval echo configure:1290: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+ac_err=`grep -v '^ *+' conftest.out`
+if test -z "$ac_err"; then
+  :
+else
+  echo "$ac_err" >&5
+  rm -rf conftest*
+  CPP=/lib/cpp
+fi
+rm -f conftest*
+fi
+rm -f conftest*
+  ac_cv_prog_CPP="$CPP"
+fi
+  CPP="$ac_cv_prog_CPP"
+else
+  ac_cv_prog_CPP="$CPP"
+fi
+echo "$ac_t""$CPP" 1>&6
+
+for ac_hdr in libgen.h sys/timeb.h posix/time.h
+do
+ac_safe=`echo "$ac_hdr" | tr './\055' '___'`
+echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
+if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  cat > conftest.$ac_ext <<EOF
+#line 1318 "configure"
+#include "confdefs.h"
+#include <$ac_hdr>
+EOF
+ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
+{ (eval echo configure:1323: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+ac_err=`grep -v '^ *+' conftest.out`
+if test -z "$ac_err"; then
+  rm -rf conftest*
+  eval "ac_cv_header_$ac_safe=yes"
+else
+  echo "$ac_err" >&5
+  rm -rf conftest*
+  eval "ac_cv_header_$ac_safe=no"
+fi
+rm -f conftest*
+fi
+if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+    ac_tr_hdr=HAVE_`echo $ac_hdr | tr 'abcdefghijklmnopqrstuvwxyz./\055' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ___'`
+  cat >> confdefs.h <<EOF
+#define $ac_tr_hdr 1
+EOF
+ 
+else
+  echo "$ac_t""no" 1>&6
+fi
+done
+
+     for ac_hdr in sys/select.h
+do
+ac_safe=`echo "$ac_hdr" | tr './\055' '___'`
+echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
+if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  cat > conftest.$ac_ext <<EOF
+#line 1355 "configure"
+#include "confdefs.h"
+#include <$ac_hdr>
+EOF
+ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
+{ (eval echo configure:1360: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
+ac_err=`grep -v '^ *+' conftest.out`
+if test -z "$ac_err"; then
+  rm -rf conftest*
+  eval "ac_cv_header_$ac_safe=yes"
+else
+  echo "$ac_err" >&5
+  rm -rf conftest*
+  eval "ac_cv_header_$ac_safe=no"
+fi
+rm -f conftest*
+fi
+if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+    ac_tr_hdr=HAVE_`echo $ac_hdr | tr 'abcdefghijklmnopqrstuvwxyz./\055' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ___'`
+  cat >> confdefs.h <<EOF
+#define $ac_tr_hdr 1
+EOF
+ 
+else
+  echo "$ac_t""no" 1>&6
+fi
+done
+
+     for ac_func in dlopen gettimeofday ftime nlist select setitimer sigaction
+do
+echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
+if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  cat > conftest.$ac_ext <<EOF
+#line 1391 "configure"
+#include "confdefs.h"
+/* System header to define __stub macros and hopefully few prototypes,
+    which can conflict with char $ac_func(); below.  */
+#include <assert.h>
+/* Override any gcc2 internal prototype to avoid an error.  */
+/* We use char because int might match the return type of a gcc2
+    builtin and then its argument prototype would still apply.  */
+char $ac_func();
+
+int main() { return 0; }
+int t() {
+
+/* The GNU C library defines this for functions which it implements
+    to always fail with ENOSYS.  Some functions are actually named
+    something starting with __ and the normal name is an alias.  */
+#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
+choke me
+#else
+$ac_func();
+#endif
+
+; return 0; }
+EOF
+if { (eval echo configure:1415: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+  rm -rf conftest*
+  eval "ac_cv_func_$ac_func=yes"
+else
+  rm -rf conftest*
+  eval "ac_cv_func_$ac_func=no"
+fi
+rm -f conftest*
+
+fi
+if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+    ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'`
+  cat >> confdefs.h <<EOF
+#define $ac_tr_func 1
+EOF
+ 
+else
+  echo "$ac_t""no" 1>&6
+fi
+done
+
+     for ac_func in socket chroot
+do
+echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
+if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  cat > conftest.$ac_ext <<EOF
+#line 1444 "configure"
+#include "confdefs.h"
+/* System header to define __stub macros and hopefully few prototypes,
+    which can conflict with char $ac_func(); below.  */
+#include <assert.h>
+/* Override any gcc2 internal prototype to avoid an error.  */
+/* We use char because int might match the return type of a gcc2
+    builtin and then its argument prototype would still apply.  */
+char $ac_func();
+
+int main() { return 0; }
+int t() {
+
+/* The GNU C library defines this for functions which it implements
+    to always fail with ENOSYS.  Some functions are actually named
+    something starting with __ and the normal name is an alias.  */
+#if defined (__stub_$ac_func) || defined (__stub___$ac_func)
+choke me
+#else
+$ac_func();
+#endif
+
+; return 0; }
+EOF
+if { (eval echo configure:1468: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+  rm -rf conftest*
+  eval "ac_cv_func_$ac_func=yes"
+else
+  rm -rf conftest*
+  eval "ac_cv_func_$ac_func=no"
+fi
+rm -f conftest*
+
+fi
+if eval "test \"`echo '$ac_cv_func_'$ac_func`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+    ac_tr_func=HAVE_`echo $ac_func | tr 'abcdefghijklmnopqrstuvwxyz' 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'`
+  cat >> confdefs.h <<EOF
+#define $ac_tr_func 1
+EOF
+ 
+else
+  echo "$ac_t""no" 1>&6
+fi
+done
+
+     echo $ac_n "checking for strerror""... $ac_c" 1>&6
+if eval "test \"`echo '$''{'ac_cv_func_strerror'+set}'`\" = set"; then
+  echo $ac_n "(cached) $ac_c" 1>&6
+else
+  cat > conftest.$ac_ext <<EOF
+#line 1495 "configure"
+#include "confdefs.h"
+/* System header to define __stub macros and hopefully few prototypes,
+    which can conflict with char strerror(); below.  */
+#include <assert.h>
+/* Override any gcc2 internal prototype to avoid an error.  */
+/* We use char because int might match the return type of a gcc2
+    builtin and then its argument prototype would still apply.  */
+char strerror();
+
+int main() { return 0; }
+int t() {
+
+/* The GNU C library defines this for functions which it implements
+    to always fail with ENOSYS.  Some functions are actually named
+    something starting with __ and the normal name is an alias.  */
+#if defined (__stub_strerror) || defined (__stub___strerror)
+choke me
+#else
+strerror();
+#endif
+
+; return 0; }
+EOF
+if { (eval echo configure:1519: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+  rm -rf conftest*
+  eval "ac_cv_func_strerror=yes"
+else
+  rm -rf conftest*
+  eval "ac_cv_func_strerror=no"
+fi
+rm -f conftest*
+
+fi
+if eval "test \"`echo '$ac_cv_func_'strerror`\" = yes"; then
+  echo "$ac_t""yes" 1>&6
+  cat >> confdefs.h <<\EOF
+#define HAVE_STRERROR 1
+EOF
+
+else
+  echo "$ac_t""no" 1>&6
+LIBOBJS="$LIBOBJS c/fake/strerror.o"
+fi
+
+     echo $ac_n "checking n_name""... $ac_c" 1>&6
+     cat > conftest.$ac_ext <<EOF
+#line 1542 "configure"
+#include "confdefs.h"
+#include <nlist.h>
+int main() { return 0; }
+int t() {
+struct nlist name_list;
+		  name_list.n_name = "foo";
+; return 0; }
+EOF
+if { (eval echo configure:1551: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+  rm -rf conftest*
+  cat >> confdefs.h <<\EOF
+#define NLIST_HAS_N_NAME 1
+EOF
+
+		 echo "$ac_t""yes" 1>&6
+else
+  rm -rf conftest*
+  echo "$ac_t""no" 1>&6
+fi
+rm -f conftest*
+
+     echo $ac_n "checking __NEXT__""... $ac_c" 1>&6
+     cat > conftest.$ac_ext <<EOF
+#line 1566 "configure"
+#include "confdefs.h"
+
+int main() { return 0; }
+int t() {
+
+#ifdef	__NeXT__
+return 0;
+#else
+fail
+#endif
+
+; return 0; }
+EOF
+if { (eval echo configure:1580: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
+  rm -rf conftest*
+  CC="$CC -posix"
+		cat >> confdefs.h <<\EOF
+#define HAVE_SIGACTION 1
+EOF
+
+		echo "$ac_t""yes" 1>&6
+else
+  rm -rf conftest*
+  echo "$ac_t""no" 1>&6
+fi
+rm -f conftest*
+
+     	echo $ac_n "checking underscore before symbols""... $ac_c" 1>&6
+	echo 'main() { return 0; } fnord() {}' >conftest.c
+	if ${CC} ${CFLAGS} ${CPPFLAGS} ${LDFLAGS} conftest.c ${LIBS} &&
+	nm a.out | grep _fnord >/dev/null; then
+		echo "$ac_t""yes" 1>&6
+		cat >> confdefs.h <<\EOF
+#define USCORE 1
+EOF
+
+	else
+		echo "$ac_t""no" 1>&6
+	fi
+	rm -f conftest.c a.out
+
+     	echo $ac_n "checking link with -rdynamic""... $ac_c" 1>&6
+	cat > conftest.$ac_ext <<EOF
+#line 1610 "configure"
+#include "confdefs.h"
+
+int main() { return 0; }
+int t() {
+#if defined(__linux__) && defined(__ELF__)
+	this must not compile
+#endif
+; return 0; }
+EOF
+if { (eval echo configure:1620: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
+  rm -rf conftest*
+  echo "$ac_t""no" 1>&6
+else
+  rm -rf conftest*
+  echo "$ac_t""yes" 1>&6
+			LDFLAGS="$LDFLAGS -rdynamic"
+fi
+rm -f conftest*
+
+
+     
+     
+     
+trap '' 1 2 15
+cat > confcache <<\EOF
+# This file is a shell script that caches the results of configure
+# tests run on this system so they can be shared between configure
+# scripts and configure runs.  It is not useful on other systems.
+# If it contains results you don't want to keep, you may remove or edit it.
+#
+# By default, configure uses ./config.cache as the cache file,
+# creating it if it does not exist already.  You can give configure
+# the --cache-file=FILE option to use a different cache file; that is
+# what configure does when it calls configure scripts in
+# subdirectories, so they share the cache.
+# Giving --cache-file=/dev/null disables caching, for debugging configure.
+# config.status only pays attention to the cache file if you give it the
+# --recheck option to rerun configure.
+#
+EOF
+# Ultrix sh set writes to stderr and can't be redirected directly,
+# and sets the high bit in the cache file unless we assign to the vars.
+(set) 2>&1 |
+  sed -n "s/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=\${\1='\2'}/p" \
+  >> confcache
+if cmp -s $cache_file confcache; then
+  :
+else
+  if test -w $cache_file; then
+    echo "updating cache $cache_file"
+    cat confcache > $cache_file
+  else
+    echo "not updating unwritable cache $cache_file"
+  fi
+fi
+rm -f confcache
+
+trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15
+
+test "x$prefix" = xNONE && prefix=$ac_default_prefix
+# Let make expand exec_prefix.
+test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'
+
+# Any assignment to VPATH causes Sun make to only execute
+# the first set of double-colon rules, so remove it if not needed.
+# If there is a colon in the path, we need to keep it.
+if test "x$srcdir" = x.; then
+  ac_vpsub='/^[ 	]*VPATH[ 	]*=[^:]*$/d'
+fi
+
+trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15
+
+DEFS=-DHAVE_CONFIG_H
+
+# Without the "./", some shells look in PATH for config.status.
+: ${CONFIG_STATUS=./config.status}
+
+echo creating $CONFIG_STATUS
+rm -f $CONFIG_STATUS
+cat > $CONFIG_STATUS <<EOF
+#! /bin/sh
+# Generated automatically by configure.
+# Run this file to recreate the current configuration.
+# This directory was configured as follows,
+# on host `(hostname || uname -n) 2>/dev/null | sed 1q`:
+#
+# $0 $ac_configure_args
+#
+# Compiler output produced by configure, useful for debugging
+# configure, is in ./config.log if it exists.
+
+ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]"
+for ac_option
+do
+  case "\$ac_option" in
+  -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)
+    echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion"
+    exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;;
+  -version | --version | --versio | --versi | --vers | --ver | --ve | --v)
+    echo "$CONFIG_STATUS generated by autoconf version 2.10"
+    exit 0 ;;
+  -help | --help | --hel | --he | --h)
+    echo "\$ac_cs_usage"; exit 0 ;;
+  *) echo "\$ac_cs_usage"; exit 1 ;;
+  esac
+done
+
+ac_given_srcdir=$srcdir
+ac_given_INSTALL="$INSTALL"
+
+trap 'rm -fr `echo "Makefile c/sysdep.h" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15
+EOF
+cat >> $CONFIG_STATUS <<EOF
+
+# Protect against being on the right side of a sed subst in config.status.
+sed 's/%@/@@/; s/@%/@@/; s/%g\$/@g/; /@g\$/s/[\\\\&%]/\\\\&/g;
+ s/@@/%@/; s/@@/@%/; s/@g\$/%g/' > conftest.subs <<\\CEOF
+$ac_vpsub
+$extrasub
+s%@CFLAGS@%$CFLAGS%g
+s%@CPPFLAGS@%$CPPFLAGS%g
+s%@CXXFLAGS@%$CXXFLAGS%g
+s%@DEFS@%$DEFS%g
+s%@LDFLAGS@%$LDFLAGS%g
+s%@LIBS@%$LIBS%g
+s%@exec_prefix@%$exec_prefix%g
+s%@prefix@%$prefix%g
+s%@program_transform_name@%$program_transform_name%g
+s%@bindir@%$bindir%g
+s%@sbindir@%$sbindir%g
+s%@libexecdir@%$libexecdir%g
+s%@datadir@%$datadir%g
+s%@sysconfdir@%$sysconfdir%g
+s%@sharedstatedir@%$sharedstatedir%g
+s%@localstatedir@%$localstatedir%g
+s%@libdir@%$libdir%g
+s%@includedir@%$includedir%g
+s%@oldincludedir@%$oldincludedir%g
+s%@infodir@%$infodir%g
+s%@mandir@%$mandir%g
+s%@CC@%$CC%g
+s%@INSTALL_PROGRAM@%$INSTALL_PROGRAM%g
+s%@INSTALL_DATA@%$INSTALL_DATA%g
+s%@CPP@%$CPP%g
+s%@LIBOBJS@%$LIBOBJS%g
+
+CEOF
+EOF
+cat >> $CONFIG_STATUS <<EOF
+
+CONFIG_FILES=\${CONFIG_FILES-"Makefile"}
+EOF
+cat >> $CONFIG_STATUS <<\EOF
+for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then
+  # Support "outfile[:infile]", defaulting infile="outfile.in".
+  case "$ac_file" in
+  *:*) ac_file_in=`echo "$ac_file"|sed 's%.*:%%'`
+       ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;;
+  *) ac_file_in="${ac_file}.in" ;;
+  esac
+
+  # Adjust relative srcdir, etc. for subdirectories.
+
+  # Remove last slash and all that follows it.  Not all systems have dirname.
+  ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'`
+  if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then
+    # The file is in a subdirectory.
+    test ! -d "$ac_dir" && mkdir "$ac_dir"
+    ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`"
+    # A "../" for each directory in $ac_dir_suffix.
+    ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'`
+  else
+    ac_dir_suffix= ac_dots=
+  fi
+
+  case "$ac_given_srcdir" in
+  .)  srcdir=.
+      if test -z "$ac_dots"; then top_srcdir=.
+      else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;;
+  /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;;
+  *) # Relative path.
+    srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix"
+    top_srcdir="$ac_dots$ac_given_srcdir" ;;
+  esac
+
+  case "$ac_given_INSTALL" in
+  [/$]*) INSTALL="$ac_given_INSTALL" ;;
+  *) INSTALL="$ac_dots$ac_given_INSTALL" ;;
+  esac
+  echo creating "$ac_file"
+  rm -f "$ac_file"
+  configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure."
+  case "$ac_file" in
+  *Makefile*) ac_comsub="1i\\
+# $configure_input" ;;
+  *) ac_comsub= ;;
+  esac
+  sed -e "$ac_comsub
+s%@configure_input@%$configure_input%g
+s%@srcdir@%$srcdir%g
+s%@top_srcdir@%$top_srcdir%g
+s%@INSTALL@%$INSTALL%g
+" -f conftest.subs $ac_given_srcdir/$ac_file_in > $ac_file
+fi; done
+rm -f conftest.subs
+
+# These sed commands are passed to sed as "A NAME B NAME C VALUE D", where
+# NAME is the cpp macro being defined and VALUE is the value it is being given.
+#
+# ac_d sets the value in "#define NAME VALUE" lines.
+ac_dA='s%^\([ 	]*\)#\([ 	]*define[ 	][ 	]*\)'
+ac_dB='\([ 	][ 	]*\)[^ 	]*%\1#\2'
+ac_dC='\3'
+ac_dD='%g'
+# ac_u turns "#undef NAME" with trailing blanks into "#define NAME VALUE".
+ac_uA='s%^\([ 	]*\)#\([ 	]*\)undef\([ 	][ 	]*\)'
+ac_uB='\([ 	]\)%\1#\2define\3'
+ac_uC=' '
+ac_uD='\4%g'
+# ac_e turns "#undef NAME" without trailing blanks into "#define NAME VALUE".
+ac_eA='s%^\([ 	]*\)#\([ 	]*\)undef\([ 	][ 	]*\)'
+ac_eB='$%\1#\2define\3'
+ac_eC=' '
+ac_eD='%g'
+
+CONFIG_HEADERS=${CONFIG_HEADERS-"c/sysdep.h"}
+for ac_file in .. $CONFIG_HEADERS; do if test "x$ac_file" != x..; then
+  # Support "outfile[:infile]", defaulting infile="outfile.in".
+  case "$ac_file" in
+  *:*) ac_file_in=`echo "$ac_file"|sed 's%.*:%%'`
+       ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;;
+  *) ac_file_in="${ac_file}.in" ;;
+  esac
+
+  echo creating $ac_file
+
+  rm -f conftest.frag conftest.in conftest.out
+  cp $ac_given_srcdir/$ac_file_in conftest.in
+
+EOF
+
+# Transform confdefs.h into a sed script conftest.vals that substitutes
+# the proper values into config.h.in to produce config.h.  And first:
+# Protect against being on the right side of a sed subst in config.status.
+# Protect against being in an unquoted here document in config.status.
+rm -f conftest.vals
+cat > conftest.hdr <<\EOF
+s/[\\&%]/\\&/g
+s%[\\$`]%\\&%g
+s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%${ac_dA}\1${ac_dB}\1${ac_dC}\2${ac_dD}%gp
+s%ac_d%ac_u%gp
+s%ac_u%ac_e%gp
+EOF
+sed -n -f conftest.hdr confdefs.h > conftest.vals
+rm -f conftest.hdr
+
+# This sed command replaces #undef with comments.  This is necessary, for
+# example, in the case of _POSIX_SOURCE, which is predefined and required
+# on some systems where configure will not decide to define it.
+cat >> conftest.vals <<\EOF
+s%^[ 	]*#[ 	]*undef[ 	][ 	]*[a-zA-Z_][a-zA-Z_0-9]*%/* & */%
+EOF
+
+# Break up conftest.vals because some shells have a limit on
+# the size of here documents, and old seds have small limits too.
+# Maximum number of lines to put in a single here document.
+ac_max_here_lines=12
+
+rm -f conftest.tail
+while :
+do
+  ac_lines=`grep -c . conftest.vals`
+  # grep -c gives empty output for an empty file on some AIX systems.
+  if test -z "$ac_lines" || test "$ac_lines" -eq 0; then break; fi
+  # Write a limited-size here document to conftest.frag.
+  echo '  cat > conftest.frag <<CEOF' >> $CONFIG_STATUS
+  sed ${ac_max_here_lines}q conftest.vals >> $CONFIG_STATUS
+  echo 'CEOF
+  sed -f conftest.frag conftest.in > conftest.out
+  rm -f conftest.in
+  mv conftest.out conftest.in
+' >> $CONFIG_STATUS
+  sed 1,${ac_max_here_lines}d conftest.vals > conftest.tail
+  rm -f conftest.vals
+  mv conftest.tail conftest.vals
+done
+rm -f conftest.vals
+
+cat >> $CONFIG_STATUS <<\EOF
+  rm -f conftest.frag conftest.h
+  echo "/* $ac_file.  Generated automatically by configure.  */" > conftest.h
+  cat conftest.in >> conftest.h
+  rm -f conftest.in
+  if cmp -s $ac_file conftest.h 2>/dev/null; then
+    echo "$ac_file is unchanged"
+    rm -f conftest.h
+  else
+    # Remove last slash and all that follows it.  Not all systems have dirname.
+      ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'`
+      if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then
+      # The file is in a subdirectory.
+      test ! -d "$ac_dir" && mkdir "$ac_dir"
+    fi
+    rm -f $ac_file
+    mv conftest.h $ac_file
+  fi
+fi; done
+
+
+
+exit 0
+EOF
+chmod +x $CONFIG_STATUS
+rm -fr confdefs* $ac_clean_files
+test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1
+
diff --git a/configure.in b/configure.in
new file mode 100644
index 0000000..d7c1341
--- /dev/null
+++ b/configure.in
@@ -0,0 +1,130 @@
+dnl Process this file with autoconf to produce a configure script.
+dnl
+dnl We might want AC_WORDS_BIGENDIAN in the future.
+dnl We might want AC_CHAR_UNSIGNED in the future.
+dnl
+dnl The -cckr (K&R) flag is for the IRIX C compiler.  If this is left
+dnl out, scheme48vm.c breaks because the rather pedantic SGI compiler
+dnl decides that a char is not the same thing as an unsigned char.
+dnl - Bryan O'Sullivan 3/94
+dnl Note, this test didn't work correctly on Sun's which take -cckr as a
+dnl synonym for -c. (HCC)
+define(S48_CFLAG_CKR, [dnl
+	if test "z$GCC" = z; then
+		AC_MSG_CHECKING([-cckr])
+		oldCFLAGS="$CFLAGS"
+		CFLAGS="$CFLAGS -cckr"
+		AC_TRY_RUN([int main() { return 0;}],
+			[AC_MSG_RESULT(yes)],
+			[AC_MSG_RESULT(no)
+				CFLAGS="$oldCFLAGS"],
+			[AC_MSG_RESULT(no)
+				CFLAGS="$oldCFLAGS"])
+	fi
+])dnl
+dnl
+define(S48_POSIX_LIBC, [dnl
+echo checking for RISC/OS POSIX library lossage
+if test -f /usr/posix/usr/lib/libc.a; then
+  LIBS="${LIBS} /usr/posix/usr/lib/libc.a"
+fi
+])dnl
+dnl
+dnl Run AC_PROG_CC, but don't accept it's changes to CFLAGS.
+dnl For some insane reason, it sets CFLAGS to either `-O' or `-g -O' for gcc.
+dnl I don't want the silly -g (because if you are using nlist, you can't strip
+dnl the binary), I want -O2 for gcc and -O for other C compilers.
+define(S48_PROG_CC, [dnl
+	oldCFLAGS="$CFLAGS"
+	AC_PROG_CC
+	if test "z$oldCFLAGS" = z; then
+		if test "z$GCC" = z; then
+			CFLAGS='-O'
+		else
+			CFLAGS='-O2'
+		fi
+	fi
+])dnl
+dnl
+dnl Linux/ELF systems need the -rdynamic flag when linking so that
+dnl dlsym() can find symbols in the executable.
+dnl Note, on some Sun's, you can link with -rdynamic but the resulting
+dnl a.out always core dumps.
+define(S48_RDYNAMIC, [dnl
+	AC_MSG_CHECKING([link with -rdynamic])
+	AC_TRY_COMPILE([],
+[#if defined(__linux__) && defined(__ELF__)
+	this must not compile
+#endif],
+		[AC_MSG_RESULT(no)],
+		[AC_MSG_RESULT(yes)
+			LDFLAGS="$LDFLAGS -rdynamic"])
+])dnl
+dnl
+define(S48_USCORE, [dnl
+	AC_MSG_CHECKING([underscore before symbols])
+	echo 'main() { return 0; } fnord() {}' >conftest.c
+	if ${CC} ${CFLAGS} ${CPPFLAGS} ${LDFLAGS} conftest.c ${LIBS} &&
+	nm a.out | grep _fnord >/dev/null; then
+		AC_MSG_RESULT([yes])
+		AC_DEFINE(USCORE)
+	else
+		AC_MSG_RESULT([no])
+	fi
+	rm -f conftest.c a.out
+])dnl
+dnl
+AC_INIT(c/scheme48vm.c)
+     AC_CONFIG_HEADER(c/sysdep.h)
+     S48_PROG_CC
+     AC_ISC_POSIX
+     dnl set the cross-compile flag before we try anything.
+     AC_TRY_RUN([int main() { return 0;}], [], [], [true])
+     S48_CFLAG_CKR
+     AC_PROG_INSTALL
+     AC_CHECK_LIB(m, main)
+     AC_CHECK_LIB(dl, main)
+     AC_CHECK_LIB(mld, main)
+     AC_CHECK_LIB(nsl, main)
+     AC_CHECK_LIB(gen, main)
+     AC_CHECK_LIB(socket, main)
+     AC_CHECK_LIB(sun, getpwnam)
+     dnl Solaris 2.3 seems to need -lelf for nlist().  (tnx Bryan O'Sullivan)
+     AC_CHECK_LIB(elf, main)
+     S48_POSIX_LIBC
+     AC_CONST
+     AC_RETSIGTYPE
+     AC_CHECK_HEADERS(libgen.h sys/timeb.h posix/time.h)
+     AC_CHECK_HEADERS(sys/select.h)
+     AC_CHECK_FUNCS(gettimeofday ftime nlist select setitimer sigaction)
+     AC_CHECK_FUNC(dlopen, AC_DEFINE(HAVE_DLOPEN),
+			   AC_CHECK_FUNC(nlist, [LIBOBJS="$LIBOBJS c/fake/libdl1.c],
+						[LIBOBJS="$LIBOBJS c/fake/libdl2.c]))
+     AC_CHECK_FUNCS(socket chroot)
+     AC_CHECK_FUNC(strerror, AC_DEFINE(HAVE_STRERROR),
+			      [LIBOBJS="$LIBOBJS c/fake/strerror.o"])
+     AC_MSG_CHECKING([n_name])
+     AC_TRY_LINK([#include <nlist.h>],
+		 [struct nlist name_list;
+		  name_list.n_name = "foo";],
+		 AC_DEFINE(NLIST_HAS_N_NAME)
+		 AC_MSG_RESULT([yes]),
+		 AC_MSG_RESULT([no]))
+     AC_MSG_CHECKING([__NEXT__])
+     AC_TRY_LINK(,[
+#ifdef	__NeXT__
+return 0;
+#else
+fail
+#endif
+],
+		CC="$CC -posix"
+		AC_DEFINE(HAVE_SIGACTION)
+		AC_MSG_RESULT([yes]),
+		AC_MSG_RESULT([no]))
+     S48_USCORE
+     S48_RDYNAMIC
+     AC_SUBST(CFLAGS)
+     AC_SUBST(LIBOBJS)
+     AC_SUBST(LDFLAGS)
+AC_OUTPUT(Makefile)
diff --git a/doc/big-scheme.txt b/doc/big-scheme.txt
new file mode 100644
index 0000000..0f03197
--- /dev/null
+++ b/doc/big-scheme.txt
@@ -0,0 +1,309 @@
+
+		     Documentation for Big Scheme
+
+				   
+Big Scheme is a set of generally useful facilities.
+
+Easiest way to access these things:
+
+    > ,open big-scheme
+    Load structure big-scheme (y/n)? y
+    ...
+
+A better way is to use the module system.
+
+-----
+
+Ascii conversions
+
+(CHAR->ASCII <char>) => <integer>
+(ASCII->CHAR <integer>) => <char>
+  These are identical to CHAR->INTEGER and INTEGER->CHAR except that
+  they use the ASCII encoding.
+
+-----
+
+Bitwise operations
+
+(BITWISE-NOT <integer>) => <integer>
+(BITWISE-AND <integer> <integer>) => <integer>
+(BITWISE-IOR <integer> <integer>) => <integer>
+(BITWISE-XOR <integer> <integer>) => <integer>
+  These perform various logical operations on integers on a bit-by-bit
+  basis, using a two's-complement representation.
+
+(ARITHMETIC-SHIFT <integer> <bit-count>) => <integer>
+  Shift the integer by the given bit count, shifting left for positive
+  counts and right for negative ones.  A two's complement
+  representation is used.
+
+-----
+
+Hash tables
+
+(MAKE-TABLE) => <table>
+(MAKE-STRING-TABLE) => <string-table>
+  Make a new, empty table.  MAKE-TABLE returns a table that uses EQ?
+  for comparing keys and an ad-hoc hash function.  String tables uses
+  strings for keys.
+
+(MAKE-TABLE-MAKER <comparison-procedure> <hash-procedure>) => <procedure>
+  Returns a procedure of no arguments that makes tables that use the
+  given comparison and hash procedures.
+  (<comparison-procedure> <key1> <key2>) => <boolean>
+  (<hash-procedure> <key>) => <non-negative-integer>
+
+(TABLE? <x>) => <boolean>
+  True if <x> is a table.
+
+(TABLE-REF <table> <key>) => <x>
+  Return the value for <key> in <table>, or #F if there is none.
+  <key> should be of a type appropriate for <table>.
+
+(TABLE-SET! <table> <key> <value>) => <undefined>
+  Make <value> be the value of <key> in <table>.  <key> should be of a
+  type appropriate for <table>.
+
+(TABLE-WALK <procedure> <table>) => <undefined>
+  Apply <procedure>, which must accept two arguments, to every
+  associated key and value in <table>.
+
+-----
+
+Enumerations
+
+(DEFINE-ENUMERATION <type-name> (<name0> <name1> ...))      *SYNTAX*
+  Defines <type-name> to be an enumeration with components <name0>
+  <name1> ....  Also defines <type-name>-COUNT to be the number of
+  components.
+
+(ENUM <type-name> <component-name>) => <integer>            *SYNTAX*
+  Evaluates to the value of <component-name> within the enumeration
+  <type-name>.  For example, if (DEFINE-ENUMERATION COLOR (GREEN
+  RED)), then (ENUM COLOR GREEN) is zero and (ENUM COLOR RED) is one.
+  The mapping from name to integer is done at macro-expansion time, so
+  there is no run-time overhead.
+
+(ENUMERAND->NAME <integer> <enumeration>) => <symbol>
+  Returns the name associated with <integer> within <enumeration>.
+  E.g. (ENUMERAND->NAME 1 COLOR) => 'RED.
+
+(NAME->ENUMERAND <symbol> <enumeration>)  => <integer>
+  Returns the integer associated with <symbol> within <enumeration>.
+  E.g. (ENUMERAND->NAME 'GREEN COLOR) => 0.
+
+-----
+
+Port extensions
+
+(MAKE-TRACKING-INPUT-PORT  <input-port>)  => <input-port>
+(MAKE-TRACKING-OUTPUT-PORT <output-port>) => <output-port>
+  These return ports that keep track of the current row and column and
+  are otherwise identical to their arguments.
+
+(MAKE-STRING-INPUT-PORT <string>) => <input-port>
+  Returns a port that reads characters from the supplied string.
+
+(CALL-WITH-STRING-OUTPUT-PORT <procedure>) => <string>
+  The procedure is called on a port.  When it returns, CALL-WITH-STRING-
+  OUTPUT-PORT returns a string containing the characters written to the port.
+
+(WRITE-ONE-LINE <output-port> <character-count> <procedure>) => <unspecified>
+  The procedure is called on an output port.  Output written to that
+  port is copied to <output-port> until <character-count> characters
+  have been written, at which point WRITE-ONE-LINE returns.
+
+(CURRENT-ROW    <port>) => <integer> or #f
+(CURRENT-COLUMN <port>) => <integer> or #f
+  These return the current read or write location of the port.  #F is
+  returned if the port does not keep track of its location.
+
+(FRESH-LINE <output-port>) => <undefined>
+  Write a newline character to <output-port> if its current column is not 0.
+
+(INPUT-PORT?  <any>) => <boolean>
+(OUTPUT-PORT? <any>) => <boolean>
+  These are versions of the standard Scheme predicates that answer true for
+  extended ports.
+
+-----
+
+Queues
+
+(MAKE-QUEUE) => <queue>
+  Returns a new, empty queue.
+
+(ENQUEUE! <queue> <x>) => <undefined>
+  Puts <x> on the queue.
+
+(DEQUEUE! <queue>) => <x>
+  Removes and returns the first element of the queue.
+
+(QUEUE-EMPTY? <queue>) => <boolean>
+  True if the queue is empty.
+
+(QUEUE? <x>) => <boolean>
+  True if <x> is a queue.
+
+(QUEUE->LIST <queue>) => <list>
+  Returns a list of the elements of the queue, in order.
+
+(QUEUE-LENGTH <queue>) => <integer>
+  The number of elements currently on the queue.
+
+(DELETE-FROM-QUEUE! <queue> <x>) => <boolean>
+  Removes the first occurance of <x> from the queue, returning true if
+  it was found and false otherwise.
+
+-----
+
+Little utility procedures
+
+(ATOM? <any>)          => <boolean>
+  (ATOM? x) == (NOT (PAIR? x))
+
+(NULL-LIST? <list>)    => <boolean>
+  Returns #t for the empty list, #f for a pair, and signals an error
+  otherwise.
+
+(NEQ? <any> <any>)     => <boolean>
+  (NEQ? x y) is the same as (NOT (EQ? x y)).
+
+(N= <number> <number>) => <boolean>
+  (N= x y) is the same as (NOT (= x y)).
+
+(IDENTITY <any>) => <any>
+(NO-OP <any>)    => <any>
+  These both just return their argument.  NO-OP is guaranteed not to
+  be compiled in-line, IDENTITY may be.
+
+-----
+
+List utilities
+
+(MEMQ? <element> <list>) => <boolean>
+  Returns true if <element> is in <list>, false otherwise.
+
+(ANY?   <predicate> <list>) => <boolean>
+  Returns true if <predicate> is true for any element of <list>.
+
+(EVERY? <predicate> <list>) => <boolean>
+  Returns true if <predicate> is true for every element of <list>.
+
+(ANY   <predicate> <list>)
+(FIRST <predicate> <list>)
+  ANY returns some element of <list> for which <predicate> is true, or
+  #F if there are none.  FIRST does the same except that it returns
+  the first element for which <predicate> is true.
+
+(FILTER  <predicate> <list>)
+(FILTER! <predicate> <list>)
+  Returns a list containing all of the elements of <list> for which
+  <predicate> is true.  The order of the elements is preserved.
+  FILTER! may reuse the storage of <list>.
+
+(FILTER-MAP <procedure> <list>)
+  The same as FILTER except the returned list contains the results of
+  applying <procedure> instead of elements of <list>.  (FILTER-MAP p
+  l) is the same as (FILTER IDENTITY (MAP p l)).
+
+(PARTITION-LIST  <predicate> <list>) => <list> <list>
+(PARTITION-LIST! <predicate> <list>) => <list> <list>
+  The first return value contains those elements <list> for which
+  <predicate> is true, the second contains the remaining elements.
+  The order of the elements is preserved.  PARTITION-LIST! may resuse
+  the storage of the <list>.
+
+(REMOVE-DUPLICATES <list>) => <list>
+  Returns its argument with all duplicate elements removed.  The first
+  instance of each element is preserved.
+
+(DELQ   <element>   <list>) => <list>
+(DELQ!  <element>   <list>) => <list>
+(DELETE <predicate> <list>) => <list>
+  All three of these return <list> with some elements removed.  DELQ
+  removes all elements EQ? to <element>.  DELQ! does the same and may
+  modify the list argument.  DELETE removes all elements for which
+  <predicate> is true.  Both DELQ and DELETE may reuse some of the
+  storage in the list argument, but won't modify it.
+
+(REVERSE! <list>) => <list>
+  Destructively reverses <list>.
+
+(SORT-LIST  <list> <a<b-procedure>) => <list>
+(SORT-LIST! <list> <a<b-procedure>) => <list>
+  Returns a sorted copy of <list>.  The sorting algorithm is stable.
+  (SORT-LIST '(6 5 1 3 2 4) <) => '(1 2 3 4 5 6)
+
+-----
+
+Additional syntax
+
+(DESTRUCTURE ((<pattern> <init>) ...) <body> ...)              *SYNTAX*
+  The <init>s are evaluated and their values are dissasembled
+  according to the corresponding patterns, with identifiers in the
+  patterns being bound to fresh locations holding the corresponding
+  part, and the body is evaluated in the extended environment.
+  Patterns may be any of the following:
+
+     #f                     Discard the corresponding part.
+     <identifier>           Bind the <indentifier> to the part.
+     (<pattern> ...)        The part must be a list at least as long as the
+                             pattern.
+     (<pattern1> ... . <patternN>)
+                            The same thing, except that the final CDR of the
+                             part is dissasembled according to <patternN>.
+     #(<pattern> ...)       The part must be a vector at least as long as the
+                             pattern.
+
+(RECEIVE <identifiers> <exp> <body> ...)                       *SYNTAX*
+  => (CALL-WITH-VALUES (LAMBDA () <exp>) (LAMBDA <identifiers> <body> ...))
+  Bind <identifiers> to the values returned by <exp>, and evaluate the
+  body in the resulting environment.
+
+-----
+
+Printing and related procedures
+
+(CONCATENATE-SYMBOL . <components>)
+  Returns the symbol whose name is produced by concatenating the DISPLAYed
+  representations of <components>.
+  (CONCATENATE-SYMBOL 'abc "-" 4) => 'abc-4
+
+(FORMAT <port-spec> <format-string> . <arguments>) => <string> or <undefined>
+  Prints the arguments to the port as directed by the string.  <port-spec>
+  should be either:
+    An output port.  The output is written directly to the port.  The result
+       of the call to FORMAT is undefined.
+    #T.  The output is written to the current output port.  The result of the
+       call to FORMAT is undefined.
+    #F.  The output is written to a string, which is then the value returned
+       from the call to FORMAT.
+  Characters in <format-string> which are not preceded by a ~ are written
+  directly to the output.  Characters preceded by a ~ have the following
+  meaning (case is irrelevant; ~a and ~A have the same meaning):
+    ~~ prints a single ~
+    ~A prints the next argument using DISPLAY
+    ~D prints the next argument as a decimal number
+    ~S prints the next argument using WRITE
+    ~% prints a newline character
+    ~& prints a NEWLINE character if the previous printed character was not one
+       (this is implemented using FRESH-LINE)
+    ~? performs a recursive call to FORMAT using the next two arguments as the
+       string and the list of arguments
+
+(ERROR <format-string> . <format-arguments>)
+(BREAKPOINT <format-string> . <format-arguments>)
+  Signals an error or breakpoint condition, passing it the result of
+  applying FORMAT to the arguments.
+
+(P <thing>)
+(P <thing> <output-port>)
+(PRETTY-PRINT <thing> <output-port> <position>)
+  Pretty-print <thing>.  The current output port is used if no port is
+  specified.  <position> is the starting offset.  <thing> will be
+  pretty-printed to the right of this column.
+
+
+Original by RK, 26 Jan 1993.
+Minor changes by JAR, 5 Dec 1993.
diff --git a/doc/external.ps b/doc/external.ps
new file mode 100644
index 0000000..2f3d093
--- /dev/null
+++ b/doc/external.ps
@@ -0,0 +1,4430 @@
+%!PS-Adobe-2.0
+%%Creator: dvipsk 5.58f Copyright 1986, 1994 Radical Eye Software
+%%Title: external.dvi
+%%Pages: 13
+%%PageOrder: Ascend
+%%BoundingBox: 0 0 612 792
+%%DocumentPaperSizes: Letter
+%%EndComments
+%DVIPSCommandLine: /usr/bin/dvips -D 600 -f external.dvi
+%DVIPSParameters: dpi=600, comments removed
+%DVIPSSource:  TeX output 1999.02.23:1806
+%%BeginProcSet: tex.pro
+/TeXDict 250 dict def TeXDict begin /N{def}def /B{bind def}N /S{exch}N
+/X{S N}B /TR{translate}N /isls false N /vsize 11 72 mul N /hsize 8.5 72
+mul N /landplus90{false}def /@rigin{isls{[0 landplus90{1 -1}{-1 1}
+ifelse 0 0 0]concat}if 72 Resolution div 72 VResolution div neg scale
+isls{landplus90{VResolution 72 div vsize mul 0 exch}{Resolution -72 div
+hsize mul 0}ifelse TR}if Resolution VResolution vsize -72 div 1 add mul
+TR[matrix currentmatrix{dup dup round sub abs 0.00001 lt{round}if}
+forall round exch round exch]setmatrix}N /@landscape{/isls true N}B
+/@manualfeed{statusdict /manualfeed true put}B /@copies{/#copies X}B
+/FMat[1 0 0 -1 0 0]N /FBB[0 0 0 0]N /nn 0 N /IE 0 N /ctr 0 N /df-tail{
+/nn 8 dict N nn begin /FontType 3 N /FontMatrix fntrx N /FontBBox FBB N
+string /base X array /BitMaps X /BuildChar{CharBuilder}N /Encoding IE N
+end dup{/foo setfont}2 array copy cvx N load 0 nn put /ctr 0 N[}B /df{
+/sf 1 N /fntrx FMat N df-tail}B /dfs{div /sf X /fntrx[sf 0 0 sf neg 0 0]
+N df-tail}B /E{pop nn dup definefont setfont}B /ch-width{ch-data dup
+length 5 sub get}B /ch-height{ch-data dup length 4 sub get}B /ch-xoff{
+128 ch-data dup length 3 sub get sub}B /ch-yoff{ch-data dup length 2 sub
+get 127 sub}B /ch-dx{ch-data dup length 1 sub get}B /ch-image{ch-data
+dup type /stringtype ne{ctr get /ctr ctr 1 add N}if}B /id 0 N /rw 0 N
+/rc 0 N /gp 0 N /cp 0 N /G 0 N /sf 0 N /CharBuilder{save 3 1 roll S dup
+/base get 2 index get S /BitMaps get S get /ch-data X pop /ctr 0 N ch-dx
+0 ch-xoff ch-yoff ch-height sub ch-xoff ch-width add ch-yoff
+setcachedevice ch-width ch-height true[1 0 0 -1 -.1 ch-xoff sub ch-yoff
+.1 sub]{ch-image}imagemask restore}B /D{/cc X dup type /stringtype ne{]}
+if nn /base get cc ctr put nn /BitMaps get S ctr S sf 1 ne{dup dup
+length 1 sub dup 2 index S get sf div put}if put /ctr ctr 1 add N}B /I{
+cc 1 add D}B /bop{userdict /bop-hook known{bop-hook}if /SI save N @rigin
+0 0 moveto /V matrix currentmatrix dup 1 get dup mul exch 0 get dup mul
+add .99 lt{/QV}{/RV}ifelse load def pop pop}N /eop{SI restore userdict
+/eop-hook known{eop-hook}if showpage}N /@start{userdict /start-hook
+known{start-hook}if pop /VResolution X /Resolution X 1000 div /DVImag X
+/IE 256 array N 0 1 255{IE S 1 string dup 0 3 index put cvn put}for
+65781.76 div /vsize X 65781.76 div /hsize X}N /p{show}N /RMat[1 0 0 -1 0
+0]N /BDot 260 string N /rulex 0 N /ruley 0 N /v{/ruley X /rulex X V}B /V
+{}B /RV statusdict begin /product where{pop product dup length 7 ge{0 7
+getinterval dup(Display)eq exch 0 4 getinterval(NeXT)eq or}{pop false}
+ifelse}{false}ifelse end{{gsave TR -.1 .1 TR 1 1 scale rulex ruley false
+RMat{BDot}imagemask grestore}}{{gsave TR -.1 .1 TR rulex ruley scale 1 1
+false RMat{BDot}imagemask grestore}}ifelse B /QV{gsave newpath transform
+round exch round exch itransform moveto rulex 0 rlineto 0 ruley neg
+rlineto rulex neg 0 rlineto fill grestore}B /a{moveto}B /delta 0 N /tail
+{dup /delta X 0 rmoveto}B /M{S p delta add tail}B /b{S p tail}B /c{-4 M}
+B /d{-3 M}B /e{-2 M}B /f{-1 M}B /g{0 M}B /h{1 M}B /i{2 M}B /j{3 M}B /k{
+4 M}B /w{0 rmoveto}B /l{p -4 w}B /m{p -3 w}B /n{p -2 w}B /o{p -1 w}B /q{
+p 1 w}B /r{p 2 w}B /s{p 3 w}B /t{p 4 w}B /x{0 S rmoveto}B /y{3 2 roll p
+a}B /bos{/SS save N}B /eos{SS restore}B end
+%%EndProcSet
+TeXDict begin 40258431 52099146 1000 600 600 (external.dvi)
+@start /Fa 3 119 df<1C007F00FF80FF80FF80FF80FF807F001C000909798817>58
+D<03E0007F000007F801FFE0000E3C0781F0001C3E1E00F800383F3800FC00303F7000FC
+00303FE0007C00703FC0007C00603F80007C00603F80007C00E03F0000FC00C07F0000FC
+00C07E0000FC00C07E0000FC00007E0001FC0000FE0001F80000FC0001F80000FC0001F8
+0000FC0003F80001FC0003F00001F80003F00001F80007F00001F80007E00003F80007E0
+0003F0000FE03003F0000FC03003F0001FC07007F0001F806007E0001F806007E0001F80
+E007E0001F00C00FE0001F01C00FC0001F01800FC0001F03800FC0001F07001FC0000F0E
+001F800007FC0007000001F0002C267EA432>110 D<00F80003C003FE0007E0070F000F
+E00E0F800FF01C0F800FF0180F800FF0380F8007F0300F8003F0701F8001F0601F8001F0
+601F8000F0E03F8000E0C03F0000E0C07F0000E0007E0000E0007E0000C000FE0000C000
+FC0000C000FC0001C001FC00018001F800018001F800038001F800030003F800030003F0
+00070003F000060003F0000E0003F0000C0003F0001C0003F000180003F000380003F000
+700001F000E00001F801C00000FC038000007E0F0000001FFE00000007F0000024267EA4
+28>118 D E /Fb 7 109 df<7FFE0000003FFF007FFF0000007FFF00FFFF800000FFFF80
+FFFFC00001FFFF80FFFFC00001FFFF807FFFC00001FFFF007FFFE00003FFFF0003FFE000
+03FFE00003FBE00003EFE00003FBF00007EFE00003FBF00007EFE00003FBF00007EFE000
+03F9F00007CFE00003F9F8000FCFE00003F9F8000FCFE00003F9F8000FCFE00003F9FC00
+1FCFE00003F8FC001F8FE00003F8FC001F8FE00003F8FE003F8FE00003F8FE003F8FE000
+03F87E003F0FE00003F87E003F0FE00003F87F007F0FE00003F87F007F0FE00003F83F00
+7E0FE00003F83F80FE0FE00003F83F80FE0FE00003F81F80FC0FE00003F81FC1FC0FE000
+03F81FC1FC0FE00003F80FC1F80FE00003F80FC1F80FE00003F80FE3F80FE00003F80FE3
+F80FE00003F807E3F00FE00003F807E3F00FE00003F807F7F00FE00003F803F7E00FE000
+03F803F7E00FE00003F803F7E00FE00003F801FFC00FE00003F801FFC00FE00003F801FF
+C00FE00003F800FF800FE00003F800FF800FE00003F800FF800FE00003F8007F000FE000
+03F8003E000FE00003F80000000FE00003F80000000FE00003F80000000FE00003F80000
+000FE00003F80000000FE00003F80000000FE00003F80000000FE00003F80000000FE000
+03F80000000FE00003F80000000FE00003F80000000FE00003F80000000FE00003F80000
+000FE00003F80000000FE00003F80000000FE00003F80000000FE00003F80000000FE000
+7FFFC00001FFFF007FFFC00001FFFF00FFFFE00003FFFF80FFFFE00003FFFF80FFFFE000
+03FFFF807FFFC00001FFFF007FFFC00001FFFF0039497EC83E>77
+D<000FFFC0000000007FFFF800000001FFFFFE00000003FFFFFF80000007FFFFFFE00000
+0FFFFFFFF000000FFFFFFFF800001FFC007FFC00001FF8000FFE00001FF80007FE00001F
+F80001FF00001FF80001FF00000FF00000FF800007E000007F8000000000007FC0000000
+00003FC000000000003FC000000000003FC000000000003FC000000000003FC000000000
+003FC000000003FFFFC00000007FFFFFC0000003FFFFFFC000001FFFFFFFC000007FFFFF
+FFC00000FFFFFFFFC00003FFFFC03FC00007FFF8003FC0000FFF80003FC0001FFC00003F
+C0003FF000003FC0003FE000003FC0007FC000003FC0007F8000003FC000FF8000003FC0
+00FF0000003FC000FF0000003FC000FF0000003FC000FF0000003FC000FF0000003FC000
+FF8000007FC0007F8000007FC0007FC00000FFC0003FE00003FFC0003FF8000FFFE0001F
+FF00FFFFFFF80FFFFFFFFFFFF80FFFFFFFFFFFFC07FFFFFFCFFFFC01FFFFFF07FFFC00FF
+FFFC03FFF8003FFFF0007FF80007FF00000000363679B43E>97 D<00001FF800000000FF
+FF80000003FFFFE000000FFFFFF800001FFFFFFC00007FFFFFFE0000FFFFFFFF0001FFF8
+0FFF8001FFC001FFC003FF8000FFE007FE00003FE00FFC00001FF00FF800000FF01FF000
+000FF81FF0000007F83FE0000007FC3FE0000007FC7FC0000003FC7FC0000003FC7F8000
+0003FE7F80000003FEFF80000001FEFF80000001FEFFFFFFFFFFFEFFFFFFFFFFFEFFFFFF
+FFFFFEFFFFFFFFFFFEFFFFFFFFFFFEFFFFFFFFFFFCFFFFFFFFFFFCFF0000000000FF8000
+000000FF80000000007F80000000007F80000000007FC0000000003FC0000000003FE000
+0000FC3FE0000000FC1FF0000001FE1FF8000001FE0FFC000003FE07FE000007FE07FF00
+000FFC03FF80001FFC01FFE0007FF800FFFC03FFF0007FFFFFFFE0003FFFFFFFC0001FFF
+FFFF800007FFFFFF000001FFFFFC0000007FFFE000000007FF00002F3679B43E>101
+D<00000001FFC00000000FFFF00000003FFFFC000000FFFFFE000001FFFFFE000003FFFF
+FF000007FFFFFF00000FFF03FF00001FF803FF00001FF001FE00003FE001FE00003FC000
+FC00007FC0000000007F80000000007F80000000007F80000000007F80000000007F8000
+0000007F80000000007F80000000007F80000000007F80000000007F8000003FFFFFFFFF
+F07FFFFFFFFFF0FFFFFFFFFFF8FFFFFFFFFFF8FFFFFFFFFFF87FFFFFFFFFF07FFFFFFFFF
+F000007F80000000007F80000000007F80000000007F80000000007F80000000007F8000
+0000007F80000000007F80000000007F80000000007F80000000007F80000000007F8000
+0000007F80000000007F80000000007F80000000007F80000000007F80000000007F8000
+0000007F80000000007F80000000007F80000000007F80000000007F80000000007F8000
+0000007F80000000007F80000000007F80000000007F80000000007F80000000007F8000
+0000007F80000000007F80000000007F80000000007F80000000007F80000000007F8000
+0000007F8000003FFFFFFFFF003FFFFFFFFF007FFFFFFFFF807FFFFFFFFF807FFFFFFFFF
+803FFFFFFFFF003FFFFFFFFF00304A7CC93E>I<00003E00000000007F0000000000FF80
+00000001FFC000000001FFC000000001FFC000000001FFC000000001FFC000000000FF80
+000000007F00000000003E00000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000000
+00000000000000000000000000003FFFFF8000007FFFFF8000007FFFFFC000007FFFFFC0
+00007FFFFFC000007FFFFFC000003FFFFFC0000000003FC0000000003FC0000000003FC0
+000000003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC0
+000000003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC0
+000000003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC0
+000000003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC0
+000000003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC0
+000000003FC0000000003FC0000000003FC0000000003FC000007FFFFFFFFF80FFFFFFFF
+FFC0FFFFFFFFFFC0FFFFFFFFFFC0FFFFFFFFFFC0FFFFFFFFFFC07FFFFFFFFF802A4A76C9
+3E>105 D<7FFF00000000007FFF0000000000FFFF8000000000FFFF8000000000FFFF80
+000000007FFF80000000007FFF8000000000003F8000000000003F8000000000003F8000
+000000003F8000000000003F8000000000003F8000000000003F8000000000003F800000
+0000003F8000000000003F8000000000003F8000000000003F8000000000003F80000000
+00003F8000000000003F8000000000003F801FFFFFF0003F803FFFFFF0003F803FFFFFF8
+003F803FFFFFF8003F803FFFFFF8003F803FFFFFF0003F801FFFFFF0003F80003FF00000
+3F80007FE000003F8000FFC000003F8001FF8000003F8003FF0000003F8007FE0000003F
+800FFC0000003F801FF80000003F803FF00000003F807FE00000003F80FFC00000003F81
+FF800000003F83FF000000003F87FE000000003F8FFE000000003F9FFF000000003FBFFF
+800000003FFFFFC00000003FFFFFC00000003FFFBFE00000003FFF1FF00000003FFE0FF8
+0000003FFC07F80000003FF807FC0000003FF003FE0000003FE001FF0000003FC000FF00
+00003F8000FF8000003F80007FC000003F80003FE000003F80001FE000003F80001FF000
+003F80000FF800003F800007FC00003F800003FC00003F800003FE00003F800001FF007F
+FFFFC03FFFFE7FFFFFC03FFFFEFFFFFFE07FFFFFFFFFFFE07FFFFFFFFFFFE07FFFFF7FFF
+FFC03FFFFE7FFFFFC03FFFFE38497DC83E>107 D<7FFFFFC00000FFFFFFC00000FFFFFF
+E00000FFFFFFE00000FFFFFFE00000FFFFFFE000007FFFFFE0000000001FE0000000001F
+E0000000001FE0000000001FE0000000001FE0000000001FE0000000001FE0000000001F
+E0000000001FE0000000001FE0000000001FE0000000001FE0000000001FE0000000001F
+E0000000001FE0000000001FE0000000001FE0000000001FE0000000001FE0000000001F
+E0000000001FE0000000001FE0000000001FE0000000001FE0000000001FE0000000001F
+E0000000001FE0000000001FE0000000001FE0000000001FE0000000001FE0000000001F
+E0000000001FE0000000001FE0000000001FE0000000001FE0000000001FE0000000001F
+E0000000001FE0000000001FE0000000001FE0000000001FE0000000001FE0000000001F
+E0000000001FE0000000001FE0000000001FE0000000001FE0000000001FE0000000001F
+E0000000001FE0000000001FE0000000001FE0000000001FE0000000001FE0000000001F
+E0000000001FE0000000001FE0000000001FE000007FFFFFFFFFF8FFFFFFFFFFFCFFFFFF
+FFFFFCFFFFFFFFFFFCFFFFFFFFFFFCFFFFFFFFFFFC7FFFFFFFFFF82E4978C83E>I
+E /Fc 2 111 df<000E00001F00003F00003F00003E00001C0000000000000000000000
+000000000000000000000003E00007F0000C7800187C00307C00307C00607C0060F800C0
+F800C0F80001F00001F00001F00003E00003E00007C00007C00007C1800F81800F81801F
+03001F03001F06000F0C000F1C0007F00003E00011287DA617>105
+D<07801FC0000FE07FF00018F0E0F80030F1807C0030FB007C0060FE003C0060FC003C00
+60F8003C00C1F8007C00C1F0007C0001F0007C0001F0007C0003E000F80003E000F80003
+E000F80003E001F00007C001F00007C001F06007C003E06007C003E0600F8007C0C00F80
+07C0C00F8007C1800F8003C3001F0003C7001F0001FE000E0000F800231B7D9929>110
+D E /Fd 4 58 df<003F800001FFF00003E0F80007803C000F001E001E000F003E000F80
+3E000F803C0007807C0007C07C0007C07C0007C07C0007C0FC0007E0FC0007E0FC0007E0
+FC0007E0FC0007E0FC0007E0FC0007E0FC0007E0FC0007E0FC0007E0FC0007E0FC0007E0
+FC0007E0FC0007E07C0007C07C0007C07C0007C03E000F803E000F803E000F801F001F00
+0F001E0007803C0003E0F80001FFF000003F80001B277EA521>48
+D<00380000780001F8001FF800FEF800E0F80000F80000F80000F80000F80000F80000F8
+0000F80000F80000F80000F80000F80000F80000F80000F80000F80000F80000F80000F8
+0000F80000F80000F80000F80000F80000F80000F80000F80000F80000F80000F80001FC
+00FFFFF8FFFFF815267BA521>I<00FF000003FFE0000E03F0001800F80030007C006000
+7E0078003F00FC003F00FE001F80FE001F80FE001F80FE001F807C001F8000001F800000
+1F0000003F0000003E0000007E0000007C000000F8000001F0000003E0000003C0000007
+8000000E0000001C0000003800000070018000E001800180018003000300060003000C00
+03001FFFFF003FFFFF007FFFFE00FFFFFE00FFFFFE0019267DA521>I<007F000001FFC0
+0007C1E0000F0070001E0078003E003C003C003E007C001E007C001E00FC001F00FC001F
+00FC001F00FC001F00FC001F80FC001F80FC001F80FC001F807C003F807C003F803C003F
+803E007F801E007F800F01DF8007FF9F8001FE1F8000101F0000001F0000001F0000003E
+003C003E007E003C007E003C007E0078007E00F0007C00E0003003C0001C0780000FFF00
+0003F8000019277DA521>57 D E /Fe 4 111 df<0003F00000000FFC7800003FFFFC00
+007FFFFC0000FFFFFC0001FE1FFC0003FC0FF80007F80FF8000FF007F8000FE007F8001F
+C007F0001F8007F0003F8007F0003F0007F0007F0007E0007E0007E0007E0007E0007E00
+0FE000FE000FE000FC000FC000FC000FC000FC001FC180FC001F87E0FC003F87E0FC003F
+87E0FC007F8FE0FC00FF0FC0FC01FF0FC0FE03FF0FC07E07FF1F807F0FFF3F803FFFFFFF
+001FFFDFFF001FFF8FFE0007FE07FC0001F801F000232476A32C>97
+D<00007F000003FFC0000FFFF0003FFFF8007FFFFC00FFC1FC01FE00FC03FC007E07F800
+7E0FE000FE0FE000FC1FC000FC3F8001FC3F0007F87F003FF87FFFFFF07FFFFFE07FFFFF
+80FFFFFE00FFFFF000FC000000FC000000FC000000FC000000FC000000FC0000007E0000
+007E00001C7F00003E3F8000FE3FC00FFE1FFFFFFE0FFFFFFC07FFFFF001FFFFC0007FFE
+001F2475A32C>101 D<00707E007E000079FF81FF8000FFFFC7FFC000FFFFCFFFC000FF
+FFFFFFE000FFC3FFC3E001FF83FF83E001FF03FF03F001FE03FE03F001FC03FC03E003FC
+03FC03E003F803F803E003F803F803E003F007F007E007F007F007C007F007F007C007E0
+07E007C00FE00FE00FC00FC00FC00F800FC00FC00F801FC01FC01F801F801F801F001F80
+1F801F001F801F803F003F803F803E003F003F003E003F003F007E003F003F007C007F00
+7F007C007E007E007C007E007E007C007E007E007F00FE00FE007F00FC00FC003F80FC00
+FC003F00780078000F002C247DA32C>109 D<01F007F00007F81FFC000FFC7FFE001FFE
+FFFF003FFFFFFF803F3FFE1F803F3FF81F807E3FF01F807E3FE01F807E7FC01F80FE7FC0
+1F80FC7F801F80FC7F001F80FCFF003F8000FE003F0000FE003F0000FE003F0001FC007F
+0001FC007E0001FC007E0001F800FE0003F800FC1803F800FC7E03F001FC7E03F001F87E
+07F001F8FE07F003F8FC07E003F0FC07E003F1FC0FE003F1F80FE003F3F00FC003FFF00F
+C001FFE00FC001FFC00F8000FF800700003E0027247AA32C>I E
+/Ff 24 122 df<7FFFF87FFFF8FFFFF8FFFFF8FFFFF0150579941E>45
+D<0E003F807F80FF80FF80FF80FF007E003C000909778819>I<00000003FE000E000000
+3FFF801E000000FFFFE03C000003FE01F03C00000FF000787C00003FC0003CFC00007F00
+001FF80000FE00000FF80003FC00000FF80007F8000007F8000FF0000007F0001FE00000
+03F0003FC0000003F0003F80000003F0007F00000003E000FF00000003E001FE00000003
+E001FC00000003E003FC00000003C007F800000003C007F800000003C00FF000000003C0
+0FF000000003801FE000000003801FE000000000001FE000000000003FC000000000003F
+C000000000003FC000000000007FC000000000007F8000000000007F8000000000007F80
+0000000000FF800000000000FF000000000000FF000000000000FF000000000000FF0000
+00000000FF000000003800FF000000003800FF000000007800FE000000007000FF000000
+007000FF00000000F0007F00000000E0007F00000001E0007F00000001C0007F00000003
+C0003F8000000780003F8000000700001F8000000E00001FC000001E00000FC000003C00
+000FE0000078000007F00001F0000003F80003C0000001FE000F800000007F807E000000
+003FFFFC000000000FFFE00000000000FF00000000373D74BA3B>67
+D<0000F800000007FE0000001F871C00003E03FE00007C03FE0000F801FE0001F801FE00
+03F000FC0007E000FC000FE000FC000FC001FC001FC001F8001FC001F8003F8001F8003F
+8003F8007F8003F0007F0003F0007F0003F0007F0007F000FF0007E000FE0007E000FE00
+07E000FE000FE000FE000FC000FC000FC1C0FC000FC1C0FC001FC1C0FC001F83C0FC001F
+8380FC003F8380FC003F87807C007F87007C00FF07003E01FF0F003E038F8E001F0F079E
+0007FE03FC0001F000F000222677A42A>97 D<003F00001FFF00001FFF00001FFF000000
+7F0000007E0000007E0000007E000000FE000000FC000000FC000000FC000001FC000001
+F8000001F8000001F8000003F8000003F0000003F0000003F0000007F0000007E0F80007
+E7FE0007EF0F800FFC07C00FF807C00FF003E00FE003E01FC003F01FC003F01F8003F01F
+8003F03F8003F03F0003F03F0003F03F0007F07F0007F07E0007F07E0007F07E000FF0FE
+000FF0FC000FE0FC000FE0FC001FE0FC001FC0F8001FC0F8003F80F8003F80F8003F00F8
+007F00F8007E00F800FC007801F8007C01F0003C03E0003E07C0001E1F80000FFE000001
+F000001C3B77B926>I<00007F000003FFC0000FC1E0001F0070007E007800FC003801F8
+01F803F003F807F003F807E003F80FE003F81FC003F01FC000003F8000003F8000007F80
+00007F0000007F0000007F000000FF000000FE000000FE000000FE000000FE000000FC00
+0000FC000000FC000000FC000030FC000038FC0000787C0000F07E0001E03E0003C03E00
+0F801F003E000F81F80003FFE00000FF00001D2677A426>I<00000001F8000000FFF800
+0000FFF8000000FFF800000003F800000003F000000003F000000007F000000007F00000
+0007E000000007E00000000FE00000000FE00000000FC00000000FC00000001FC0000000
+1FC00000001F800000001F800000003F800000003F800000F83F000007FE3F00001F877F
+00003E03FF00007C03FE0000F801FE0001F801FE0003F000FE0007E000FC000FE000FC00
+0FC001FC001FC001FC001FC001F8003F8001F8003F8003F8007F8003F8007F0003F0007F
+0003F0007F0007F000FF0007F000FE0007E000FE0007E000FE000FE000FE000FE000FC00
+0FC1C0FC000FC1C0FC001FC1C0FC001FC3C0FC001F8380FC003F8380FC003F87807C007F
+87007C00FF07003E01FF0F003E038F8E001F0F079E0007FE03FC0001F000F000253B77B9
+2A>I<00007F000003FFC0000FC1E0003F00F0007E007800FC007801F8007803F0007807
+E000780FE000780FC000F81FC000F03F8001F03F8007E03F801F807F81FF007FFFF8007F
+FF00007F000000FF000000FE000000FE000000FE000000FE000000FE000000FC000000FC
+000000FC0000307C0000387C0000787E0000F03E0001E03E0003C01F000F800F003E0007
+81F80003FFE00000FF00001D2677A426>I<00000007C00000001FF00000003E38000000
+7C3C000000F8FC000000F9FC000001F9FC000001F1FC000003F1F8000003F0F0000003F0
+00000007F000000007E000000007E000000007E000000007E00000000FE00000000FC000
+00000FC00000000FC00000000FC00000001FC00000001F8000000FFFFFC0001FFFFFC000
+1FFFFF8000003F800000003F000000003F000000003F000000003F000000007F00000000
+7E000000007E000000007E000000007E00000000FE00000000FC00000000FC00000000FC
+00000000FC00000001FC00000001F800000001F800000001F800000001F800000003F800
+000003F000000003F000000003F000000003F000000007F000000007E000000007E00000
+0007E000000007E00000000FE00000000FC00000000FC00000000FC00000001FC0000000
+1F800000001F800000001F800000001F000000003F0000001C3F0000007E3E0000007E3E
+000000FE3C000000FE7C000000FE78000000F8F000000078F00000003FC00000000F8000
+0000264C82BA19>I<000007C00000003FF0000000FC38E00001F01FF00003E01FF00007
+C00FF0000F800FF0001F8007F0003F0007E0007F0007E0007E000FE000FE000FE000FC00
+0FC001FC000FC001FC001FC003FC001FC003F8001F8003F8001F8003F8003F8007F8003F
+8007F0003F0007F0003F0007F0007F0007F0007F0007E0007E0007E0007E0007E000FE00
+07E000FE0007E000FC0003E001FC0003E003FC0003E007FC0001F00FF80000F01FF80000
+787BF800003FF3F800000FC3F000000003F000000007F000000007F000000007E0000000
+07E00000000FE00000000FC0001C000FC0007E001FC0007E001F8000FE003F0000FE007E
+0000FE00FC00007801F800007C07E000001FFF80000003FE00000024367CA426>I<0003
+F0000001FFF0000001FFF0000001FFF000000007F000000007E000000007E000000007E0
+0000000FE00000000FC00000000FC00000000FC00000001FC00000001F800000001F8000
+00001F800000003F800000003F000000003F000000003F000000007F000000007E07F000
+007E1FFC00007E783E0000FFE01F0000FFC01F8000FF800F8000FF000F8001FE000F8001
+FE000FC001FC000FC001F8001F8003F8001F8003F0001F8003F0001F8003F0003F8007F0
+003F0007E0003F0007E0003F0007E0007F000FE0007E000FC0007E000FC000FE000FC000
+FC001FC000FC001F8001FC1C1F8001F81C1F8001F83C3F8003F8383F0003F0383F0003F0
+383F0003F0707F0003E0707E0003E0F07E0003E0E07E0003E1C0FE0001E380FC0000FF00
+3800003C00263B7BB92A>I<0001C00007E00007F0000FF0000FE00007E0000380000000
+00000000000000000000000000000000000000000000000000000000000000F00003FC00
+071E000E1F001C1F001C1F00381F00383F00703F00703F00707F00F07E00E07E00E0FE00
+00FC0000FC0001FC0001F80003F80003F80003F00007F00007E00007E0000FE0E00FC0E0
+0FC1E01FC1C01F81C01F81C01F83801F03801F07001F07001F0E000F1C0007F80001E000
+143879B619>I<000FC007FFC007FFC007FFC0001FC0001F80001F80003F80003F80003F
+00003F00007F00007F00007E00007E0000FE0000FE0000FC0000FC0001FC0001FC0001F8
+0001F80003F80003F80003F00003F00007F00007F00007E00007E0000FE0000FE0000FC0
+000FC0001FC0001FC0001F80001F80003F80003F80003F00003F00007F00007F00007E0E
+007E0E00FE0E00FE1E00FC1C00FC1C00FC3C00FC3800F83800F878007870007CE0001FE0
+000F8000123B79B915>108 D<01E000FE0007F00007F803FF801FFC000E3C0F07C0783E
+001E3E3C03E1E01F001C1F7803F3C01F80383FF001F7800F80383FE001F7000F80783FC0
+01FE000F80703FC001FE000FC0703F8001FC000FC0703F0003F8001F80F07F0003F8001F
+80E07E0003F0001F80E07E0003F0001F80007E0007F0003F8000FE0007F0003F0000FC00
+07E0003F0000FC0007E0003F0000FC000FE0007F0001FC000FE0007E0001F8000FC0007E
+0001F8000FC000FE0001F8001FC000FC0003F8001FC000FC0003F0001F8001FC1C03F000
+1F8001F81C03F0003F8001F83C07F0003F8003F83807E0003F0003F03807E0003F0003F0
+3807E0007F0003F0700FE0007F0003E0700FC0007E0003E0F00FC0007E0003E0E00FC000
+FE0003E1C01FC000FE0001E3C01F8000FC0000FF000700003800003C003E2679A444>I<
+01E000FE000007F803FF80000E3C0F07C0001E3E3C03E0001C1F7803F000383FF001F000
+383FE001F000783FC001F000703FC001F800703F8001F800703F0003F000F07F0003F000
+E07E0003F000E07E0003F000007E0007F00000FE0007E00000FC0007E00000FC0007E000
+00FC000FE00001FC000FC00001F8000FC00001F8001FC00001F8001F800003F8001F8000
+03F0003F838003F0003F038003F0003F078007F0007F070007E0007E070007E0007E0700
+07E0007E0E000FE0007C0E000FC0007C1E000FC0007C1C000FC0007C38001FC0003C7800
+1F80001FE000070000078000292679A42F>I<00007F000003FFC0000FC1F0001F00F800
+7E007C00FC007C01F8007E03F0003E07F0003F07E0003F0FE0003F1FC0003F1FC0003F3F
+80003F3F80007F7F80007F7F00007F7F00007F7F0000FFFF0000FFFE0000FEFE0000FEFE
+0001FEFE0001FCFC0001FCFC0003F8FC0003F8FC0007F0FC0007E0FC000FE07C000FC07E
+001F803E003F003E007E001F00F8000F83F00003FFC00000FE0000202677A42A>I<0007
+8007C000001FE03FF000003CF0787C000038F8E03E0000787FC03E0000707F801F000070
+FF001F0000F0FE001F8000E0FE001F8000E0FC001F8001E1FC001F8001C1FC001F8001C1
+F8001F8001C1F8001F800003F8003F800003F8003F800003F0003F800003F0003F800007
+F0007F800007F0007F800007E0007F000007E0007F00000FE000FF00000FE000FE00000F
+C000FE00000FC001FC00001FC001FC00001FC001F800001F8003F800001F8003F000003F
+8007E000003FC00FC000003FC00F8000003FE01F0000007FE03E0000007F70FC0000007E
+3FF00000007E0F80000000FE0000000000FE0000000000FC0000000000FC0000000001FC
+0000000001FC0000000001F80000000001F80000000003F80000000003F80000000003F0
+0000000007F000000000FFFFC0000000FFFFC0000000FFFFC0000000293580A42A>I<03
+C003F0000FF01FFC001E783C0F001C7C700F003C3EE03F80383FC03F80387F803F80787F
+803F00707F003F00707F001C00F07E000000E0FE000000E0FC000000E0FC00000000FC00
+000001FC00000001F800000001F800000001F800000003F800000003F000000003F00000
+0003F000000007F000000007E000000007E000000007E00000000FE00000000FC0000000
+0FC00000000FC00000001FC00000001F800000001F800000001F800000003F800000003F
+000000000E00000000212679A423>114 D<0000FE000007FF80000F83C0003E00E0007C
+00F00078007000F800F001F803F001F003F001F003F001F003E003F001C003F8000003FC
+000003FFC00001FFF80001FFFE0000FFFF00007FFF80003FFF80000FFFC00000FFC00000
+3FC000001FC000000FC03E000FC07E000FC0FE000F80FE000F80FE000F80FC001F00E000
+1F00F0003E0070007C003800F8001E03E0000FFFC00001FE00001C267AA422>I<000380
+0007C0000FC0000FC0000FC0000FC0001FC0001F80001F80001F80003F80003F00003F00
+003F00007F00007E007FFFFF7FFFFFFFFFFF00FC0000FC0000FC0001FC0001F80001F800
+01F80003F80003F00003F00003F00007F00007E00007E00007E0000FE0000FC0000FC000
+0FC0001FC0001F801C1F801C1F803C3F80383F00783F00703F00F03F00E03F01C03E03C0
+1F07800F0F0007FC0001F000183579B31C>I<00F800000003FE0001C0078F0003E00E0F
+8007E01E0F8007E01C0F8007E0380F800FE0381F800FE0781F800FC0701F800FC0703F80
+1FC0F03F001FC0E03F001F80E07F001F80007E003F80007E003F8000FE003F0000FC003F
+0000FC007F0001FC007F0001F8007E0001F8007E0001F800FE0003F800FE0003F000FC0E
+03F000FC0E03F001FC1E03F001FC1C03F001F81C03E001F81C03E001F83C03F003F83803
+F007F83801F007F07001F01EF8F000F83C78E0003FF03FC0000FC00F00272679A42D>I<
+00F0000E0003FC003F00071E007F800E1F007F801C1F007F803C1F007F80381F003F8038
+3F001F80703F000F80703F000F80707F000F80F07E000F00E07E000700E0FE00070000FC
+000F0000FC000E0001FC000E0001F8000E0001F8001E0003F8001C0003F0001C0003F000
+1C0003F0003C0007F000380007E000380007E000700007E000700007E000700007E000E0
+0007E000E00007E001C00007E003C00003E003800003F007000001F00E000000F83C0000
+007FF80000000FC00000212679A426>I<0007E007C0001FF81FF800787C383C00F03E70
+3C01E01EE0FE03C01FE0FE03801FC0FE07001FC0FC0F001F80FC0E001F80700E003F8000
+1E003F00001C003F00001C003F000000007F000000007F000000007E000000007E000000
+00FE00000000FE00000000FC00000000FC00000001FC00000001FC00000001F800700001
+F800700003F800F00003F800E01C03F000E07E03F001E07E07F001C0FE07F00380FE0FF0
+0780FE0EF00F00781CF81E0078387C3C003FF03FF00007C00FC00027267CA427>120
+D<00F000000003FC0001C0071E0003E00E1F0007E01C1F0007E03C1F0007E0381F000FE0
+383F000FC0703F000FC0703F000FC0707F001FC0F07E001F80E07E001F80E0FE001F8000
+FC003F8000FC003F0001FC003F0001F8003F0001F8007F0003F8007E0003F0007E0003F0
+007E0003F000FE0007F000FC0007E000FC0007E000FC0007E001FC0007E001F80007E001
+F80007E001F80007E003F80007E003F00007E007F00003E00FF00003F01FF00001F87FE0
+00007FF7E000001FC7E00000000FE00000000FC00000000FC00000001FC0003F001F8000
+7F003F80007F003F00007F007E00007F007C00007E00FC00007001F800007003E0000038
+07C000003C1F8000000FFE00000003F0000000233679A428>I E
+/Fg 70 123 df<1C007F00FF80FF80FF80FF80FF80FF80FF80FF80FF80FF80FF80FF80FF
+80FF80FF80FF80FF807F007F007F007F007F007F007F007F007F007F007F007F007F007F
+007F003E00000000000000000000000000000000001C007F007F00FF80FF80FF807F007F
+001C0009346FB32C>33 D<3C001E007F007F00FF007F80FF007F80FF007F80FF007F80FF
+007F80FF007F807F007F007F007F007F007F007F007F007F007F007F007F007E003F007E
+003F007E003F007E003F007E003F007E003F003E003E003E003E003E003E003C001E001C
+001C00191977B32C>I<000F003C00001F807E00001F807E00001F807E00001F807E0000
+1F807E00001F807E00001F807E00001F807E00003F80FE00003F00FC00003F00FC00003F
+00FC00003F00FC007FFFFFFFF0FFFFFFFFF8FFFFFFFFF8FFFFFFFFF8FFFFFFFFF83FFFFF
+FFF0007E01F800007E01F800007E01F800007E01F800007E01F80000FE03F80000FC03F0
+0000FC03F00000FC03F00000FC03F00000FC03F00000FC03F0003FFFFFFFF0FFFFFFFFF8
+FFFFFFFFF8FFFFFFFFF8FFFFFFFFF87FFFFFFFF001F807E00001F807E00001F807E00003
+F80FE00003F00FC00003F00FC00003F00FC00003F00FC00003F00FC00003F00FC00003F0
+0FC00003F00FC00001E007800025337DB22C>I<07800007001FE0000F801FE0001F803F
+F0001F807FF8003F807FF8003F007CF8007F00FCFC007E00F87C007E00F87C00FE00F87C
+00FC00F87C01FC00F87C01F800F87C01F800F87C03F800FCFC03F0007CF803F0007FF807
+F0007FF807E0003FF00FE0001FE00FC0001FE00FC00007801FC00000001F800000003F80
+0000003F000000003F000000007F000000007E00000000FE00000000FC00000000FC0000
+0001FC00000001F800000001F800000003F800000003F000000007F000000007E0000000
+07E00000000FE00000000FC00000001FC00000001F800F00001F803FC0003F807FE0003F
+007FE0007F00FFF0007E00F9F0007E00F9F000FE01F9F800FC01F0F800FC01F0F801FC01
+F0F801F801F0F803F801F0F803F001F0F803F001F9F807F000F9F007E000F9F00FE000FF
+F00FC0007FE00FC0007FE007C0003FC00380000F0025417DB92C>37
+D<0000380000FC0001FC0003FC0007F8000FF0001FC0003F80007F0000FE0001FC0003F8
+0003F00007F00007E0000FE0000FC0001F80001F80003F80003F00003F00007F00007E00
+007E00007E0000FE0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC00
+00FC0000FC0000FC0000FE00007E00007E00007E00007F00003F00003F00003F80001F80
+001F80000FC0000FE00007E00007F00003F00003F80001FC0000FE00007F00003F80001F
+C0000FF00007F80003FC0001FC0000FC000038164272B92C>40 D<700000FC0000FE0000
+FF00007F80003FC0000FE00007F00003F80001FC0000FE00007F00003F00003F80001F80
+001FC0000FC00007E00007E00007F00003F00003F00003F80001F80001F80001F80001FC
+0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC
+0001FC0001F80001F80001F80003F80003F00003F00007F00007E00007E0000FC0001FC0
+001F80003F80003F00007F0000FE0001FC0003F80007F0000FE0003FC0007F8000FF0000
+FE0000FC0000700000164279B92C>I<000380000007C0000007C0000007C0000007C000
+0007C0000007C0002007C008F807C03EFE07C0FEFF07C1FEFFC7C7FEFFE7CFFE3FFFFFF8
+0FFFFFE003FFFF8001FFFF00007FFC00007FFC0001FFFF0003FFFF800FFFFFE03FFFFFF8
+FFE7CFFEFFC7C7FEFF07C1FEFE07C0FEF807C03E2007C0080007C0000007C0000007C000
+0007C0000007C0000007C000000380001F247AAA2C>I<0F801FE03FF07FF87FF87FFC7F
+FC7FFC3FFC1FFC0FFC00FC00F800F801F803F007F01FE07FC0FF80FF00FC0070000E1771
+8A2C>44 D<7FFFFFFF00FFFFFFFF80FFFFFFFF80FFFFFFFF80FFFFFFFF807FFFFFFF0021
+067B9B2C>I<1F003F807FC0FFE0FFE0FFE0FFE0FFE07FC03F801F000B0B708A2C>I<0000
+0007000000000F800000001F800000001F800000003F800000003F000000007F00000000
+7E00000000FE00000000FC00000001FC00000001F800000003F800000003F000000003F0
+00000007F000000007E00000000FE00000000FC00000001FC00000001F800000003F8000
+00003F000000007F000000007E00000000FE00000000FC00000000FC00000001FC000000
+01F800000003F800000003F000000007F000000007E00000000FE00000000FC00000001F
+C00000001F800000001F800000003F800000003F000000007F000000007E00000000FE00
+000000FC00000001FC00000001F800000003F800000003F000000007F000000007E00000
+0007E00000000FE00000000FC00000001FC00000001F800000003F800000003F00000000
+7F000000007E00000000FE00000000FC00000000FC00000000F800000000780000000021
+417BB92C>I<0003F80000000FFE0000003FFF8000007FFFC00000FFFFE00001FE0FF000
+03F803F80007F001FC0007E000FC000FC0007E000FC0007E001F80003F001F80003F003F
+00001F803F00001F803E00000F807E00000FC07E00000FC07E00000FC07C000007C0FC00
+0007E0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC0000
+07E0FC000007E0FC000007E0FC000007E0FC000007E0FE00000FE07E00000FC07E00000F
+C07E00000FC07E00000FC03F00001F803F00001F803F00001F801F80003F001F80003F00
+0FC0007E000FE000FE0007E000FC0007F001FC0003F803F80001FE0FF00000FFFFE00000
+7FFFC000003FFF8000000FFE00000003F8000023357CB32C>I<00070000000F8000000F
+8000001F8000001F8000003F8000007F800000FF800001FF800007FF80007FFF8000FFFF
+8000FFDF8000FF9F80007C1F8000001F8000001F8000001F8000001F8000001F8000001F
+8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F
+8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F
+8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F80007FFF
+FFE0FFFFFFF0FFFFFFF0FFFFFFF07FFFFFE01C3477B32C>I<000FF80000007FFF800001
+FFFFE00007FFFFF0000FFFFFFC001FF80FFE003FE001FF003F80007F007F00003F807E00
+001F80FE00001FC0FE00000FC0FF00000FE0FF000007E0FF000007E0FF000007E07E0000
+07E03C000007E000000007E000000007E00000000FE00000000FC00000001FC00000001F
+800000003F800000003F000000007F00000000FE00000001FC00000003FC00000007F800
+00000FF00000001FE00000003FC0000000FF80000001FE00000003FC00000007F8000000
+0FF00000003FE00000007F80000000FF00000001FE00000003FC0003C007F80007E01FE0
+0007E03FC00007E07FFFFFFFE0FFFFFFFFE0FFFFFFFFE0FFFFFFFFE07FFFFFFFC023347C
+B32C>I<000007F00000000FF80000001FF80000003FF80000003FF80000007EF8000000
+7EF8000000FCF8000001F8F8000001F8F8000003F0F8000007E0F8000007E0F800000FC0
+F800001F80F800001F80F800003F00F800007E00F800007E00F80000FC00F80001F800F8
+0001F800F80003F000F80003E000F80007E000F8000FC000F8000FC000F8001F8000F800
+3F0000F8003F0000F8007E0000F800FC0000F800FFFFFFFFFCFFFFFFFFFEFFFFFFFFFEFF
+FFFFFFFE7FFFFFFFFC000000F800000000F800000000F800000000F800000000F8000000
+00F800000000F800000000F800000000F800000000F80000007FFFF00000FFFFF80000FF
+FFF80000FFFFF800007FFFF027347EB32C>52 D<0007FC0000003FFF800000FFFFE00003
+FFFFF80007FFFFFC000FFC07FE001FF001FF001FC0007F003F80003F803F00001F807F00
+001FC07E00000FC07E00000FC07E00000FC07E00000FC07E00000FC03F00001F803F0000
+1F801F80003F001FC0007F000FF001FE0003FC07F80001FFFFF000007FFFC0000007FC00
+00007FFFC00001FFFFF00003FC07F8000FF001FE001FC0007F001F80003F003F00001F80
+7E00000FC07E00000FC0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC
+000007E0FC000007E07E00000FC07E00000FC07F00001FC03F80003F801FC0007F001FF0
+01FF000FFC07FE0007FFFFFC0003FFFFF80000FFFFE000003FFF80000007FC000023357C
+B32C>56 D<1F003F807FC0FFE0FFE0FFE0FFE0FFE07FC03F801F00000000000000000000
+000000000000000000000000000000000000001F003F807FC0FFE0FFE0FFE0FFE0FFE07F
+C03F801F000B2470A32C>58 D<0F801FC03FE07FF07FF07FF07FF07FF03FE01FC00F8000
+0000000000000000000000000000000000000000000000000000000F801FC03FE07FE07F
+F07FF07FF07FF03FF01FF00FF001F003F003E007E00FC00FC03F807F00FF00FE00F80070
+000C3071A32C>I<7FFFFFFFF0FFFFFFFFF8FFFFFFFFF8FFFFFFFFF8FFFFFFFFF83FFFFF
+FFF000000000000000000000000000000000000000000000000000000000000000000000
+0000000000003FFFFFFFF0FFFFFFFFF8FFFFFFFFF8FFFFFFFFF8FFFFFFFFF87FFFFFFFF0
+25147DA22C>61 D<003FFE000003FFFFC0000FFFFFF0001FFFFFFC003FFFFFFE007FE007
+FF007F0000FF00FE00003F80FF00001F80FF00001F80FF00001F80FF00003F807E00007F
+003C0000FF00000003FE0000000FFC0000001FF80000003FE00000007FC0000000FF0000
+0001FE00000003FC00000003F800000007F800000007F00000000FF00000000FE0000000
+0FE00000000FE00000000FE00000000FE00000000FE00000000FE000000007C000000000
+000000000000000000000000000000000000000000000000000000000000000000000000
+00000003800000000FE00000000FE00000001FF00000001FF00000001FF00000000FE000
+00000FE00000000380000021337BB22C>63 D<0000FE00000001FF00000001FF00000001
+FF00000001FF00000003FF80000003FF80000003EF80000003EF80000007EF80000007EF
+C0000007EFC0000007C7C0000007C7C000000FC7E000000FC7E000000FC7E000000FC3E0
+00001F83F000001F83F000001F83F000001F83F000001F83F000003F01F800003F01F800
+003F01F800003F01F800007E00FC00007E00FC00007E00FC00007E00FC00007E00FC0000
+FC007E0000FFFFFE0000FFFFFE0000FFFFFE0001FFFFFF0001FFFFFF0001F8003F0001F8
+003F0001F8003F0003F0001F8003F0001F8003F0001F8003F0001F8007F0001FC007E000
+0FC07FFE00FFFC7FFF01FFFCFFFF01FFFE7FFF01FFFC7FFE00FFFC27347EB32C>65
+D<7FFFFFE0007FFFFFF800FFFFFFFE007FFFFFFF007FFFFFFFC003F0003FC003F0000FE0
+03F00007F003F00003F003F00003F003F00001F803F00001F803F00001F803F00001F803
+F00001F803F00001F803F00003F003F00003F003F00007F003F0000FE003F0001FC003F0
+00FF8003FFFFFF0003FFFFFE0003FFFFFC0003FFFFFF0003FFFFFFC003F0001FE003F000
+07F003F00003F803F00001F803F00000FC03F00000FC03F00000FE03F000007E03F00000
+7E03F000007E03F000007E03F000007E03F000007E03F00000FE03F00000FC03F00001FC
+03F00003F803F0000FF803F0003FF07FFFFFFFE07FFFFFFFC0FFFFFFFF807FFFFFFE007F
+FFFFF00027337FB22C>I<0000FF00700007FFE0F8000FFFF9F8003FFFFDF8007FFFFFF8
+00FF81FFF801FE007FF803FC001FF807F0000FF807F00007F80FE00007F80FC00003F81F
+800003F81F800001F83F000001F83F000001F87F000001F87E000000F07E000000007E00
+000000FE00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC0000
+0000FC00000000FC00000000FC00000000FC00000000FC00000000FE000000007E000000
+007E000000007E000000007F000000F03F000001F83F000001F81F800001F81F800001F8
+0FC00003F80FE00003F007F00007F007F00007E003FC001FE001FE003FC000FF81FF8000
+7FFFFF00003FFFFE00000FFFFC000007FFF0000000FF800025357DB32C>I<7FFFFF0000
+FFFFFFC000FFFFFFF000FFFFFFF8007FFFFFFC0007E003FE0007E000FF0007E0007F8007
+E0003F8007E0001FC007E0000FE007E0000FE007E00007E007E00007F007E00003F007E0
+0003F807E00001F807E00001F807E00001F807E00001F807E00000FC07E00000FC07E000
+00FC07E00000FC07E00000FC07E00000FC07E00000FC07E00000FC07E00000FC07E00000
+FC07E00000FC07E00000FC07E00001F807E00001F807E00001F807E00003F807E00003F0
+07E00003F007E00007F007E00007E007E0000FE007E0001FC007E0003FC007E0007F8007
+E000FF0007E003FE007FFFFFFC00FFFFFFF800FFFFFFF000FFFFFFC0007FFFFF00002633
+7EB22C>I<7FFFFFFFF0FFFFFFFFF8FFFFFFFFF8FFFFFFFFF87FFFFFFFF803F00001F803
+F00001F803F00001F803F00001F803F00001F803F00001F803F00001F803F00000F003F0
+00000003F000000003F000000003F000000003F001E00003F003F00003F003F00003F003
+F00003F003F00003FFFFF00003FFFFF00003FFFFF00003FFFFF00003FFFFF00003F003F0
+0003F003F00003F003F00003F003F00003F001E00003F000000003F000000003F0000000
+03F000000003F000000003F000003C03F000007E03F000007E03F000007E03F000007E03
+F000007E03F000007E03F000007E03F000007E7FFFFFFFFEFFFFFFFFFEFFFFFFFFFEFFFF
+FFFFFE7FFFFFFFFC27337EB22C>I<7FFFFFFFF8FFFFFFFFFCFFFFFFFFFCFFFFFFFFFC7F
+FFFFFFFC03F00000FC03F00000FC03F00000FC03F00000FC03F00000FC03F00000FC03F0
+0000FC03F000007803F000000003F000000003F000000003F000000003F000000003F000
+F00003F001F80003F001F80003F001F80003F001F80003FFFFF80003FFFFF80003FFFFF8
+0003FFFFF80003FFFFF80003F001F80003F001F80003F001F80003F001F80003F000F000
+03F000000003F000000003F000000003F000000003F000000003F000000003F000000003
+F000000003F000000003F000000003F000000003F000000003F00000007FFFE00000FFFF
+E00000FFFFF00000FFFFE000007FFFE0000026337EB22C>I<0001FC0380000FFF87C000
+1FFFEFC0007FFFFFC000FFFFFFC001FF07FFC003FC01FFC003F800FFC007F0007FC00FE0
+003FC00FC0001FC01FC0001FC01F80001FC03F80000FC03F00000FC03F00000FC07E0000
+0FC07E000007807E000000007E00000000FE00000000FC00000000FC00000000FC000000
+00FC00000000FC00000000FC00000000FC00000000FC00000000FC0003FFF8FC0007FFFC
+FC0007FFFCFE0007FFFC7E0003FFF87E00000FC07E00000FC07E00000FC03F00001FC03F
+00001FC03F80001FC01F80001FC01FC0003FC00FC0003FC00FE0007FC007F0007FC003F8
+00FFC003FC01FFC001FF07FFC000FFFFFFC0007FFFEFC0001FFFCFC0000FFF07800001FC
+000026357DB32C>I<7FFE00FFFCFFFF01FFFEFFFF01FFFEFFFF01FFFE7FFE00FFFC07E0
+000FC007E0000FC007E0000FC007E0000FC007E0000FC007E0000FC007E0000FC007E000
+0FC007E0000FC007E0000FC007E0000FC007E0000FC007E0000FC007E0000FC007E0000F
+C007E0000FC007E0000FC007FFFFFFC007FFFFFFC007FFFFFFC007FFFFFFC007FFFFFFC0
+07E0000FC007E0000FC007E0000FC007E0000FC007E0000FC007E0000FC007E0000FC007
+E0000FC007E0000FC007E0000FC007E0000FC007E0000FC007E0000FC007E0000FC007E0
+000FC007E0000FC007E0000FC007E0000FC007E0000FC07FFE00FFFCFFFF01FFFEFFFF01
+FFFEFFFF01FFFE7FFE00FFFC27337EB22C>I<7FFFFFF8FFFFFFFCFFFFFFFCFFFFFFFC7F
+FFFFF8000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC00000
+0FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC00000
+0FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC00000
+0FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC00000
+0FC000000FC000000FC000000FC000000FC000000FC0007FFFFFF8FFFFFFFCFFFFFFFCFF
+FFFFFC7FFFFFF81E3379B22C>I<0007FFFF80000FFFFFC0000FFFFFC0000FFFFFC00007
+FFFF80000003F000000003F000000003F000000003F000000003F000000003F000000003
+F000000003F000000003F000000003F000000003F000000003F000000003F000000003F0
+00000003F000000003F000000003F000000003F000000003F000000003F000000003F000
+000003F000000003F000000003F000000003F000000003F000000003F000000003F00000
+0003F000000003F000000003F000000003F000000003F000180003F0007E0003F0007E00
+03F000FF0003F000FF0003F000FF0007E000FE000FE0007F001FE0007FC07FC0003FFFFF
+80001FFFFF00000FFFFE000003FFF80000007FC0000022347BB22C>I<7FFC007FF8FFFE
+00FFFCFFFE00FFFCFFFE00FFFC7FFC007FF807C0001F8007C0003F8007C0007F0007C000
+7E0007C000FC0007C001F80007C003F80007C007F00007C007E00007C00FC00007C01F80
+0007C03F800007C07F000007C07E000007C0FC000007C1F8000007C3F8000007C7FC0000
+07C7FC000007CFFE000007DFBE000007FFBF000007FF1F000007FE1F800007FC0FC00007
+F80FC00007F807E00007F003E00007E003F00007C001F00007C001F80007C000FC0007C0
+00FC0007C0007E0007C0003E0007C0003F0007C0001F0007C0001F8007C0000FC007C000
+0FC007C00007E07FFC001FFCFFFE003FFEFFFE003FFEFFFE003FFE7FFC001FFC27337EB2
+2C>I<7FFFE00000FFFFF00000FFFFF00000FFFFF000007FFFE0000003F000000003F000
+000003F000000003F000000003F000000003F000000003F000000003F000000003F00000
+0003F000000003F000000003F000000003F000000003F000000003F000000003F0000000
+03F000000003F000000003F000000003F000000003F000000003F000000003F000000003
+F000000003F000000003F000000003F000000003F000000003F000000003F000000003F0
+00000003F000000003F00000F003F00001F803F00001F803F00001F803F00001F803F000
+01F803F00001F803F00001F803F00001F87FFFFFFFF8FFFFFFFFF8FFFFFFFFF8FFFFFFFF
+F87FFFFFFFF025337DB22C>I<7FE0000FFCFFF0001FFEFFF0001FFEFFF8003FFE7FF800
+3FFC0FF8003FE00FBC007BE00FBC007BE00FBC007BE00FBC007BE00F9E00F3E00F9E00F3
+E00F9E00F3E00F9F01F3E00F9F01F3E00F8F01E3E00F8F01E3E00F8F83E3E00F8F83E3E0
+0F8783C3E00F87C7C3E00F87C7C3E00F83C783E00F83C783E00F83EF83E00F83EF83E00F
+81EF03E00F81EF03E00F81FF03E00F80FE03E00F80FE03E00F80FE03E00F807C03E00F80
+3803E00F800003E00F800003E00F800003E00F800003E00F800003E00F800003E00F8000
+03E00F800003E00F800003E00F800003E00F800003E00F800003E07FF0001FFCFFF8003F
+FEFFF8003FFEFFF8003FFE7FF0001FFC27337EB22C>I<7FF0007FFCFFF800FFFEFFF800
+FFFEFFFC00FFFE7FFC007FFC07FE0007C007DE0007C007DE0007C007DF0007C007CF0007
+C007CF0007C007CF8007C007C78007C007C7C007C007C7C007C007C3C007C007C3E007C0
+07C3E007C007C1E007C007C1F007C007C1F007C007C0F007C007C0F807C007C0F807C007
+C07C07C007C07C07C007C07C07C007C03E07C007C03E07C007C01E07C007C01F07C007C0
+1F07C007C00F07C007C00F87C007C00F87C007C00787C007C007C7C007C007C7C007C003
+C7C007C003E7C007C001E7C007C001E7C007C001F7C007C000F7C007C000F7C007C000FF
+C07FFC007FC0FFFE007FC0FFFE003FC0FFFE003FC07FFC001F8027337EB22C>I<007FFF
+000003FFFFE0000FFFFFF8001FFFFFFC003FFFFFFE003FE003FE003F8000FE007F00007F
+007F00007F007E00003F007E00003F007E00003F00FE00003F80FC00001F80FC00001F80
+FC00001F80FC00001F80FC00001F80FC00001F80FC00001F80FC00001F80FC00001F80FC
+00001F80FC00001F80FC00001F80FC00001F80FC00001F80FC00001F80FC00001F80FC00
+001F80FC00001F80FC00001F80FC00001F80FC00001F80FC00001F80FC00001F80FC0000
+1F80FC00001F80FC00001F80FE00003F80FE00003F807E00003F007E00003F007E00003F
+007F00007F007F00007F003F8000FE003FF007FE003FFFFFFE001FFFFFFC000FFFFFF800
+03FFFFE000007FFF000021357BB32C>I<7FFFFFC000FFFFFFF800FFFFFFFC00FFFFFFFF
+007FFFFFFF8003F000FFC003F0003FC003F0000FE003F00007F003F00007F003F00003F0
+03F00003F803F00001F803F00001F803F00001F803F00001F803F00001F803F00001F803
+F00003F803F00003F003F00007F003F00007F003F0000FE003F0003FC003F000FFC003FF
+FFFF8003FFFFFF0003FFFFFC0003FFFFF80003FFFFC00003F000000003F000000003F000
+000003F000000003F000000003F000000003F000000003F000000003F000000003F00000
+0003F000000003F000000003F000000003F000000003F000000003F00000007FFF800000
+FFFFC00000FFFFC00000FFFFC000007FFF80000025337EB22C>I<007FFF000003FFFFE0
+000FFFFFF8001FFFFFFC003FFFFFFE003FF007FE003F8000FE007F00007F007F00007F00
+7E00003F007E00003F007E00003F00FE00003F80FC00001F80FC00001F80FC00001F80FC
+00001F80FC00001F80FC00001F80FC00001F80FC00001F80FC00001F80FC00001F80FC00
+001F80FC00001F80FC00001F80FC00001F80FC00001F80FC00001F80FC00001F80FC0000
+1F80FC00001F80FC00001F80FC00001F80FC00001F80FC00001F80FC00001F80FC00001F
+80FC01F01F80FC03F81F80FE03F83F807E01FC3F007E01FC3F007E00FE3F007F00FE7F00
+7F007F7F003F807FFE003FF03FFE003FFFFFFE001FFFFFFC000FFFFFF80003FFFFE00000
+7FFFE000000007F000000007F000000003F800000003F800000001FC00000001FC000000
+00FE00000000FE000000007F000000007F000000003E0021407BB32C>I<7FFFFC000000
+FFFFFF800000FFFFFFE00000FFFFFFF800007FFFFFFC000007E007FE000007E001FE0000
+07E0007F000007E0003F800007E0001F800007E0001F800007E0000FC00007E0000FC000
+07E0000FC00007E0000FC00007E0000FC00007E0000FC00007E0001F800007E0001F8000
+07E0003F800007E0007F000007E001FE000007E007FE000007FFFFFC000007FFFFF80000
+07FFFFE0000007FFFFF0000007FFFFF8000007E007FC000007E001FE000007E000FE0000
+07E0007F000007E0003F000007E0003F000007E0003F000007E0003F000007E0003F0000
+07E0003F000007E0003F000007E0003F000007E0003F0F0007E0003F1F8007E0003F1F80
+07E0003F1F8007E0003F1F8007E0003F1F807FFE001FBF80FFFF001FFF00FFFF000FFF00
+FFFF000FFE007FFE0007FC0000000001F00029347EB22C>I<001FF8070000FFFF0F8001
+FFFFCF8007FFFFFF800FFFFFFF801FF01FFF803FC003FF803F8001FF807F0000FF807E00
+007F80FE00003F80FC00003F80FC00001F80FC00001F80FC00001F80FC00001F80FE0000
+0F007E000000007F000000007F800000003FE00000001FFC0000001FFFC000000FFFFC00
+0003FFFFC00001FFFFF000007FFFF8000007FFFC0000007FFE00000007FF00000000FF80
+0000003F800000001FC00000001FC00000000FE00000000FE078000007E0FC000007E0FC
+000007E0FC000007E0FC000007E0FC000007E0FE00000FC0FE00000FC0FF00001F80FF80
+003F80FFE0007F00FFFE01FF00FFFFFFFE00FFFFFFFC00F9FFFFF000F83FFFC0007007FF
+000023357CB32C>I<7FFFFFFFFCFFFFFFFFFEFFFFFFFFFEFFFFFFFFFEFFFFFFFFFEFC00
+7E007EFC007E007EFC007E007EFC007E007EFC007E007EFC007E007EFC007E007E78007E
+003C00007E000000007E000000007E000000007E000000007E000000007E000000007E00
+0000007E000000007E000000007E000000007E000000007E000000007E000000007E0000
+00007E000000007E000000007E000000007E000000007E000000007E000000007E000000
+007E000000007E000000007E000000007E000000007E000000007E000000007E00000000
+7E000000007E000000007E000000007E000000007E0000003FFFFC00003FFFFC00007FFF
+FE00003FFFFC00003FFFFC0027337EB22C>I<7FFF803FFFC0FFFFC07FFFE0FFFFC07FFF
+E0FFFFC07FFFE07FFF803FFFC003F00001F80003F00001F80003F00001F80003F00001F8
+0003F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003F00001F8
+0003F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003F00001F8
+0003F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003F00001F8
+0003F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003F00001F8
+0003F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003F80003F8
+0001F80003F00001F80003F00001FC0007F00000FC0007E00000FE000FE000007F001FC0
+00003F803F8000003FE0FF8000001FFFFF0000000FFFFE00000003FFF800000001FFF000
+0000003F8000002B3480B22C>I<7FFC007FFCFFFE00FFFEFFFE00FFFEFFFE00FFFE7FFC
+007FFC0FC00007E00FE0000FE007E0000FC007E0000FC007E0000FC007F0001FC003F000
+1F8003F0001F8003F0001F8003F8003F8001F8003F0001F8003F0001F8003F0001FC007F
+0000FC007E0000FC007E0000FC007E0000FC007E00007E00FC00007E00FC00007E00FC00
+007E00FC00003F01F800003F01F800003F01F800003F01F800001F83F000001F83F00000
+1F83F000001F83F000000F83E000000FC7E000000FC7E000000FC7E0000007C7C0000007
+C7C0000007EFC0000007EFC0000003EF80000003EF80000003FF80000003FF80000001FF
+00000001FF00000001FF00000001FF00000000FE000027347EB22C>I<3FFF03FFE07FFF
+07FFF07FFF87FFF07FFF07FFF03FFF03FFE001F800FE0001FC00FE0000FC01FC0000FE01
+FC00007E01F800007F03F800003F03F000003F87F000001F87E000001FCFE000000FCFC0
+00000FFFC0000007FF80000007FF80000003FF00000003FF00000001FE00000001FE0000
+0000FC00000000FC00000001FE00000001FE00000003FF00000003FF00000007FF800000
+07FFC000000FCFC000000FCFE000001FC7E000001F87F000003F83F000003F03F800007F
+01F800007E01FC0000FE00FC0000FC00FE0001FC007E0001F8007F0003F8003F0003F000
+3F8003F0001F807FFE00FFFC7FFF01FFFCFFFF01FFFE7FFF01FFFC7FFE00FFFC27337EB2
+2C>88 D<7FFC007FFCFFFE00FFFEFFFE00FFFEFFFE00FFFE7FFC007FFC07F0000FC007F0
+001FC003F0001F8003F8003F8001F8003F8001FC007F0000FC007F0000FE007E00007E00
+FE00007F00FC00003F01FC00003F81F800001F81F800001F83F000000FC3F000000FC7F0
+000007E7E0000007E7E0000003E7C0000003EFC0000001FF80000001FF80000001FF0000
+0000FF00000000FE000000007E000000007E000000007E000000007E000000007E000000
+007E000000007E000000007E000000007E000000007E000000007E000000007E00000000
+7E000000007E000000007E000000007E00000007FFE000000FFFF000000FFFF000000FFF
+F0000007FFE00027337EB22C>I<3FFFFFFFC07FFFFFFFE07FFFFFFFE07FFFFFFFE07FFF
+FFFFE07E00001FC07E00003F807E00003F807E00007F007E00007E007E0000FE007E0001
+FC003C0001F800000003F800000007F000000007F00000000FE00000001FC00000001FC0
+0000003F800000007F000000007F00000000FE00000001FC00000001FC00000003F80000
+0007F000000007F00000000FE00000001FC00000001FC00000003F800000007F00000000
+7F00000000FE00000001FC00000001FC00000003F80003C003F00007E007F00007E00FE0
+0007E00FC00007E01FC00007E03F800007E03F800007E07F000007E0FFFFFFFFE0FFFFFF
+FFE0FFFFFFFFE0FFFFFFFFE07FFFFFFFC023337CB22C>I<7FFFFFFF00FFFFFFFF80FFFF
+FFFF80FFFFFFFF80FFFFFFFF807FFFFFFF0021067B7D2C>95 D<01FFF0000007FFFE0000
+1FFFFF80001FFFFFE0003FFFFFF0003FC01FF8003FC007F8003FC001FC001F8000FC0006
+0000FE000000007E000000007E000000007E000000FFFE00001FFFFE0000FFFFFE0003FF
+FFFE000FFFFFFE001FFF807E003FF8007E007FC0007E007F00007E00FE00007E00FC0000
+7E00FC00007E00FC00007E00FC00007E00FE00007E007F0000FE007F8003FE003FE01FFE
+001FFFFFFFFC0FFFFFFFFE07FFFFBFFE01FFFE1FFE003FF007FC27247CA32C>97
+D<7FF0000000FFF8000000FFF8000000FFF80000007FF800000001F800000001F8000000
+01F800000001F800000001F800000001F800000001F800000001F800000001F800000001
+F800000001F81FE00001F8FFF80001FBFFFE0001FFFFFF0001FFFFFF8001FFF07FC001FF
+801FE001FF0007F001FE0003F801FC0003F801FC0001FC01F80000FC01F80000FC01F800
+00FE01F800007E01F800007E01F800007E01F800007E01F800007E01F800007E01F80000
+7E01F800007E01F80000FE01FC0000FC01FC0000FC01FC0001F801FE0003F801FF0007F0
+01FF000FF001FF801FE001FFE07FC001FFFFFF8001FFFFFF0001FBFFFE0001F8FFF80000
+F03FC00027337FB22C>I<0003FFE000001FFFF800007FFFFE0001FFFFFE0003FFFFFF00
+07FE00FF000FF000FF001FE000FF001FC0007E003F800018003F000000007F000000007E
+000000007E00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC00
+000000FC00000000FC000000007E000000007E000000007F000000003F00000F003F8000
+1F801FC0001F801FE0003F800FF0007F0007FE03FF0003FFFFFE0001FFFFFC00007FFFF8
+00001FFFE0000003FF000021247AA32C>I<00000FFE0000001FFF0000001FFF0000001F
+FF0000000FFF000000003F000000003F000000003F000000003F000000003F000000003F
+000000003F000000003F000000003F000000003F000007F83F00003FFE3F0000FFFFBF00
+01FFFFFF0003FFFFFF0007FC0FFF000FF003FF001FE001FF001FC000FF003F80007F003F
+00007F007E00003F007E00003F00FE00003F00FC00003F00FC00003F00FC00003F00FC00
+003F00FC00003F00FC00003F00FC00003F00FC00003F00FE00003F007E00007F007E0000
+7F007F0000FF003F8000FF003F8001FF001FC003FF000FF007FF0007FC1FFF0003FFFFFF
+FC01FFFFBFFE00FFFF3FFE003FFC3FFE000FF01FFC27337DB22C>I<0003FE0000001FFF
+C000007FFFF00001FFFFF80003FFFFFC0007FE03FE000FF800FF001FE0003F801FC0003F
+803F80001FC03F00000FC07F00000FC07E00000FE07E000007E0FC000007E0FFFFFFFFE0
+FFFFFFFFE0FFFFFFFFE0FFFFFFFFE0FFFFFFFFC0FC00000000FE000000007E000000007E
+000000007F000000003F000003C03F800007E01FC00007E00FF0000FE007F8003FC007FF
+00FFC001FFFFFF8000FFFFFF00003FFFFC00000FFFF0000001FF800023247CA32C>I<00
+000FF80000003FFE000000FFFF000001FFFF800003FFFF800007FC7F800007F07F80000F
+E03F00000FC03F00000FC00000000FC00000000FC00000000FC00000000FC00000000FC0
+00007FFFFFFE00FFFFFFFF00FFFFFFFF00FFFFFFFF007FFFFFFE00000FC00000000FC000
+00000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000
+000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC0000000
+0FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000F
+C00000000FC00000000FC000003FFFFFF0007FFFFFF8007FFFFFF8007FFFFFF8003FFFFF
+F00021337DB22C>I<00000003F80007F80FFC001FFE3FFE007FFFFFFF01FFFFFFFF03FF
+FFFE7F03FC0FF87F07F003F83E0FE001FC1C0FC000FC001FC000FE001F80007E001F8000
+7E001F80007E001F80007E001F80007E001F80007E001FC000FE000FC000FC000FE001FC
+0007F003F80003FC0FF00007FFFFF00007FFFFE0000FFFFF80000F9FFE00000F87F80000
+0F800000000F800000000F800000000FC000000007E000000007FFFFF00003FFFFFE0007
+FFFFFF800FFFFFFFE01FFFFFFFF03FC0001FF87F000003FC7E000000FC7C0000007CFC00
+00007EF80000003EF80000003EF80000003EF80000003EFC0000007E7E000000FC7F8000
+03FC3FE0000FF81FFC007FF00FFFFFFFE003FFFFFF8001FFFFFF00003FFFF8000007FFC0
+0028387EA42C>I<7FF000000000FFF800000000FFF800000000FFF8000000007FF80000
+000001F80000000001F80000000001F80000000001F80000000001F80000000001F80000
+000001F80000000001F80000000001F80000000001F80000000001F81FE0000001F87FFC
+000001F9FFFE000001FBFFFF000001FFFFFF000001FFF03F800001FFC01F800001FF801F
+C00001FF000FC00001FE000FC00001FC000FC00001FC000FC00001F8000FC00001F8000F
+C00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000F
+C00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000F
+C00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC0007FFFE0FF
+FF00FFFFF1FFFF80FFFFF1FFFF80FFFFF1FFFF807FFFE0FFFF0029337FB22C>I<000700
+00001FC000001FC000003FE000003FE000003FE000001FC000001FC00000070000000000
+000000000000000000000000000000000000000000000000007FFFC0007FFFE000FFFFE0
+007FFFE0007FFFE0000007E0000007E0000007E0000007E0000007E0000007E0000007E0
+000007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E0
+000007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E0
+000007E0007FFFFFFCFFFFFFFEFFFFFFFEFFFFFFFE7FFFFFFC1F3479B32C>I<00000E00
+00003F8000003F8000007FC000007FC000007FC000003F8000003F8000000E0000000000
+00000000000000000000000000000000000000000000000001FFFF8003FFFFC003FFFFC0
+03FFFFC001FFFFC000000FC000000FC000000FC000000FC000000FC000000FC000000FC0
+00000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC0
+00000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC0
+00000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC0
+00000FC000000FC000000FC000000FC000001FC03C001F807E003F80FF003F00FF007F00
+FF01FE00FFFFFC007FFFF8007FFFF0001FFFE00007FF00001A467CB32C>I<7FE0000000
+FFF0000000FFF0000000FFF00000007FF000000001F000000001F000000001F000000001
+F000000001F000000001F000000001F000000001F000000001F000000001F000000001F0
+1FFFF001F03FFFF801F03FFFF801F03FFFF801F01FFFF001F000FE0001F001FC0001F003
+F80001F007F00001F00FE00001F01FC00001F03F800001F07F000001F0FE000001F1FC00
+0001F3FC000001F7FE000001FFFF000001FFFF000001FF9F800001FF0FC00001FE0FE000
+01FC07E00001F803F00001F001F80001F001FC0001F000FC0001F0007E0001F0003F0001
+F0003F8001F0001F807FFFC0FFFCFFFFE1FFFEFFFFE1FFFEFFFFE1FFFE7FFFC0FFFC2733
+7EB22C>I<7FFFE00000FFFFF00000FFFFF00000FFFFF000007FFFF000000003F0000000
+03F000000003F000000003F000000003F000000003F000000003F000000003F000000003
+F000000003F000000003F000000003F000000003F000000003F000000003F000000003F0
+00000003F000000003F000000003F000000003F000000003F000000003F000000003F000
+000003F000000003F000000003F000000003F000000003F000000003F000000003F00000
+0003F000000003F000000003F000000003F000000003F000000003F000000003F0000000
+03F000000003F000000003F000000003F000007FFFFFFF80FFFFFFFFC0FFFFFFFFC0FFFF
+FFFFC07FFFFFFF8022337BB22C>I<7F83F007E0007FCFFC1FF800FFDFFE3FFC007FFFFE
+FFFC007FFFFFFFFE0007FE1FFC3E0007FC1FF83F0007F80FF01F0007F00FE01F0007E00F
+C01F0007E00FC01F0007E00FC01F0007C00F801F0007C00F801F0007C00F801F0007C00F
+801F0007C00F801F0007C00F801F0007C00F801F0007C00F801F0007C00F801F0007C00F
+801F0007C00F801F0007C00F801F0007C00F801F0007C00F801F0007C00F801F0007C00F
+801F0007C00F801F0007C00F801F0007C00F801F007FFC3FF87FF07FFC7FF8FFF0FFFE7F
+FCFFF87FFC7FF8FFF07FFC3FF87FF02D2481A32C>I<7FF01FE00000FFF87FFC0000FFF9
+FFFE0000FFFBFFFF00007FFFFFFF000001FFF03F800001FFC01F800001FF801FC00001FF
+000FC00001FE000FC00001FC000FC00001FC000FC00001F8000FC00001F8000FC00001F8
+000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8
+000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8
+000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC0007FFFE0FFFF00FFFF
+F1FFFF80FFFFF1FFFF80FFFFF1FFFF807FFFE0FFFF0029247FA32C>I<0007FC0000001F
+FF0000007FFFC00001FFFFF00003FFFFF80007FC07FC000FF001FE001FE000FF001F8000
+3F003F80003F803F00001F807E00000FC07E00000FC07E00000FC0FC000007E0FC000007
+E0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FE00000FE07E00000FC0
+7E00000FC07F00001FC03F00001F803F80003F801FC0007F001FE000FF000FF001FE0007
+FC07FC0003FFFFF80001FFFFF000007FFFC000001FFF00000007FC000023247CA32C>I<
+7FF01FE000FFF8FFF800FFFBFFFE00FFFFFFFF007FFFFFFF8001FFF07FC001FF801FE001
+FF0007F001FE0003F801FC0003F801FC0001FC01F80000FC01F80000FC01F80000FE01F8
+00007E01F800007E01F800007E01F800007E01F800007E01F800007E01F800007E01F800
+007E01F80000FE01FC0000FC01FC0000FC01FC0001F801FE0003F801FF0007F001FF000F
+F001FF801FE001FFE07FC001FFFFFF8001FFFFFF0001FBFFFE0001F8FFF80001F83FC000
+01F800000001F800000001F800000001F800000001F800000001F800000001F800000001
+F800000001F800000001F800000001F800000001F800000001F80000007FFFE00000FFFF
+F00000FFFFF00000FFFFF000007FFFE0000027367FA32C>I<7FFE003FC0FFFF01FFF0FF
+FF07FFF8FFFF1FFFFC7FFF3FFFFC003F7FE1FC003FFF01FC003FFC00F8003FF80070003F
+F00000003FE00000003FE00000003FC00000003F800000003F800000003F800000003F00
+0000003F000000003F000000003F000000003F000000003F000000003F000000003F0000
+00003F000000003F000000003F000000003F000000003F000000003F000000003F000000
+7FFFFFE000FFFFFFF000FFFFFFF000FFFFFFF0007FFFFFE00026247EA32C>114
+D<007FF87003FFFFF80FFFFFF81FFFFFF83FFFFFF87FC00FF87E0003F8FC0001F8F80001
+F8F80001F8F80001F8FC0000F07F0000007FF000003FFFC0001FFFFE000FFFFF8003FFFF
+E0007FFFF80001FFFC000007FC000000FE7800007FFC00003FFC00001FFE00001FFE0000
+1FFF00003FFF80003EFFC000FEFFF007FCFFFFFFFCFFFFFFF8FFFFFFE0F8FFFF80701FFC
+0020247AA32C>I<001E000000003F000000003F000000003F000000003F000000003F00
+0000003F000000003F000000003F000000003F0000007FFFFFFF00FFFFFFFF80FFFFFFFF
+80FFFFFFFF807FFFFFFF00003F000000003F000000003F000000003F000000003F000000
+003F000000003F000000003F000000003F000000003F000000003F000000003F00000000
+3F000000003F000000003F000000003F000000003F000000003F0003C0003F0007E0003F
+0007E0003F0007E0003F0007E0003F0007E0003F800FE0001F801FC0001FE07FC0000FFF
+FF80000FFFFF000003FFFE000001FFF80000003FE000232E7EAD2C>I<7FF003FF8000FF
+F807FFC000FFF807FFC000FFF807FFC0007FF803FFC00001F8000FC00001F8000FC00001
+F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001
+F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001
+F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001
+F8000FC00001F8001FC00001F8001FC00001F8003FC00001FC007FC00000FE03FFC00000
+FFFFFFFF00007FFFFFFF80003FFFFFFF80001FFFCFFF800003FE07FF0029247FA32C>I<
+7FFF01FFFCFFFF01FFFEFFFF83FFFEFFFF01FFFE7FFF01FFFC03E0000F8003E0000F8003
+F0001F8001F0001F0001F0001F0001F8003F0000F8003E0000F8003E0000FC007E00007C
+007C00007C007C00007E00FC00003E00F800003E00F800003F01F800001F01F000001F01
+F000001F83F000000F83E000000F83E000000FC7E0000007C7C0000007C7C0000007EFC0
+000003EF80000003EF80000003FF80000001FF00000001FF00000000FE000000007C0000
+27247EA32C>I<3FFF03FFF07FFF87FFF87FFF87FFF87FFF87FFF83FFF03FFF000FC007E
+0000FC00FC00007E01F800003F01F000001F83F000001F87E000000FCFC0000007EF8000
+0003FF80000001FF00000001FE00000000FC000000007C00000000FE00000001FE000000
+01FF00000003EF80000007CFC000000FC7C000000F83E000001F01F000003F01F800007E
+00F800007C007C0000F8007E0001F8003F007FFF01FFFC7FFF83FFFCFFFF83FFFE7FFF83
+FFFC7FFF01FFFC27247EA32C>120 D<7FFF01FFFCFFFF81FFFEFFFF83FFFEFFFF81FFFE
+7FFF01FFFC03E0000F8001F0000F8001F0001F8001F8001F0000F8001F0000F8003F0000
+FC003E00007C003E00007E007E00003E007C00003E007C00003F00FC00001F00F800001F
+00F800000F81F800000F81F000000F81F0000007C1F0000007C3E0000007C3E0000003E3
+E0000003E7C0000001E7C0000001F7C0000001F780000000FF80000000FF80000000FF00
+0000007F000000007F000000003E000000003E000000007E000000007C000000007C0000
+0000FC00000000F800000000F800000C01F800003F01F000007F83F000007F87E000007E
+0FE000007E1FC000007FFF8000003FFF0000001FFE0000000FFC00000007E00000002736
+7EA32C>I<3FFFFFFFE07FFFFFFFF07FFFFFFFF07FFFFFFFF07FFFFFFFF07E00001FE07E
+00003FC07E00007F807E0000FF007E0001FE003C0003FC00000007F80000000FF0000000
+1FE00000003FC00000007F80000000FF00000001FC00000003F80000000FF00000001FE0
+0000003FC00000007F80000000FF00000001FE0001E003FC0003F007F80003F00FF00003
+F01FE00003F03FC00003F07F800003F0FFFFFFFFF0FFFFFFFFF0FFFFFFFFF0FFFFFFFFF0
+7FFFFFFFE024247DA32C>I E /Fh 35 121 df<07C01FF03FF87FFCFFFEFFFEFFFEFFFE
+FFFEFFFEFFFE7FFC3FF81FF007C00F0F788E1F>46 D<000003C000000007C00000001FC0
+0000007FC0000003FFC000003FFFC000FFFFFFC000FFFFFFC000FFFFFFC000FFFFFFC000
+FFC3FFC0000003FFC0000003FFC0000003FFC0000003FFC0000003FFC0000003FFC00000
+03FFC0000003FFC0000003FFC0000003FFC0000003FFC0000003FFC0000003FFC0000003
+FFC0000003FFC0000003FFC0000003FFC0000003FFC0000003FFC0000003FFC0000003FF
+C0000003FFC0000003FFC0000003FFC0000003FFC0000003FFC0000003FFC0000003FFC0
+000003FFC0000003FFC0000003FFC0000003FFC0000003FFC0000003FFC0000003FFC000
+0003FFC0000003FFC0000003FFC0000003FFC0000003FFC0000003FFC0000003FFC00000
+03FFC0000003FFC0000003FFC0000003FFC0000003FFC0000003FFC0000003FFC000FFFF
+FFFFFCFFFFFFFFFCFFFFFFFFFCFFFFFFFFFCFFFFFFFFFC264177C038>49
+D<0000FFE00000000FFFFE0000003FFFFF800000FFFFFFE00003FFFFFFF80007FC03FFFE
+000FE0007FFF001F80003FFF803F00000FFFC07F000007FFC07FC00007FFE07FF00003FF
+E0FFF00001FFF0FFF80001FFF0FFF80001FFF8FFF80000FFF8FFF80000FFF8FFF80000FF
+F8FFF80000FFF87FF00000FFF83FE00000FFF81FC00000FFF800000000FFF800000000FF
+F000000001FFF000000001FFF000000001FFE000000003FFE000000003FFC000000007FF
+800000000FFF000000000FFF000000001FFC000000003FF8000000003FF0000000007FE0
+00000000FFC000000001FF0000000003FE0000000007FC000000000FF0000000001FE000
+0000003F80000000007F0000780000FE0000780001FC0000780003F80000F80007E00000
+F0000FC00000F0001F800000F0003F000000F0007C000001F000F8000003F001FFFFFFFF
+F003FFFFFFFFE007FFFFFFFFE00FFFFFFFFFE01FFFFFFFFFE03FFFFFFFFFE07FFFFFFFFF
+E0FFFFFFFFFFE0FFFFFFFFFFC0FFFFFFFFFFC0FFFFFFFFFFC0FFFFFFFFFFC02D417BC038
+>I<0000FFF000000007FFFF0000001FFFFFC000007FFFFFF00000FF007FF80003F8003F
+FE0007E0001FFF0007E0000FFF000FF80007FF800FFE0007FF801FFE0007FFC01FFF0007
+FFC01FFF0007FFC01FFF0007FFC01FFF0007FFC01FFF0007FFC01FFF0007FFC00FFE0007
+FFC007FC0007FF8003F8000FFF800000000FFF000000001FFF000000001FFE000000003F
+FC000000007FF800000000FFF000000001FFE00000000FFF80000007FFFE00000007FFF8
+00000007FFFF00000007FFFFC000000000FFF0000000003FFC000000000FFE000000000F
+FF8000000007FF8000000003FFC000000003FFE000000003FFE000000001FFF000000001
+FFF000000001FFF800000001FFF800000001FFF80FC00001FFF83FF00001FFF87FF80001
+FFF87FF80001FFF8FFFC0001FFF8FFFC0001FFF8FFFC0001FFF0FFFC0001FFF0FFFC0003
+FFF0FFFC0003FFE07FF80003FFE07FF00007FFC07FE00007FFC03F80000FFF801FF0001F
+FF000FFE00FFFE0007FFFFFFF80001FFFFFFF000007FFFFFC000001FFFFE00000001FFE0
+00002D427BC038>I<1E00000000001F00000000001FFC000000001FFFFFFFFFFE1FFFFF
+FFFFFE1FFFFFFFFFFE1FFFFFFFFFFE3FFFFFFFFFFE3FFFFFFFFFFC3FFFFFFFFFF83FFFFF
+FFFFF03FFFFFFFFFE03FFFFFFFFFC03FFFFFFFFFC07FFFFFFFFF807E0000003F007C0000
+007E007C000000FC0078000000F80078000001F80078000003F000F8000007E000F00000
+0FC000F000000F8000F000001F80000000003F00000000007E0000000000FC0000000000
+FC0000000001F80000000003F80000000003F00000000007F0000000000FE0000000000F
+E0000000001FE0000000001FC0000000003FC0000000003FC0000000007FC0000000007F
+8000000000FF8000000000FF8000000001FF8000000001FF8000000001FF8000000003FF
+8000000003FF0000000003FF0000000003FF0000000007FF0000000007FF0000000007FF
+0000000007FF0000000007FF000000000FFF000000000FFF000000000FFF000000000FFF
+000000000FFF000000000FFF000000000FFF000000000FFF000000000FFF000000000FFF
+0000000007FE0000000003FC0000000001F80000002F447AC238>55
+D<00007FF000000007FFFE0000001FFFFF8000007FFFFFE00000FFE03FF00001FF800FF8
+0003FF0007FC0007FE0007FE000FFC0003FF001FFC0001FF003FFC0001FF803FFC0001FF
+807FF80001FFC07FF80000FFC07FF80000FFE07FF80000FFE0FFF80000FFE0FFF80000FF
+F0FFF80000FFF0FFF80000FFF0FFF80000FFF0FFF80000FFF0FFF80000FFF0FFF80000FF
+F8FFF80000FFF8FFF80000FFF8FFF80000FFF8FFF80001FFF87FF80001FFF87FF80001FF
+F87FF80001FFF83FF80003FFF83FF80003FFF81FFC0003FFF81FFC0007FFF80FFE000FFF
+F807FE000FFFF803FF001EFFF801FFC07CFFF800FFFFF8FFF8003FFFF0FFF8000FFFC0FF
+F00001FF00FFF000000000FFF000000000FFF000000000FFE000000001FFE000000001FF
+E003C00001FFE00FF00001FFC01FF80001FFC03FFC0003FF803FFC0003FF803FFC0003FF
+003FFC0007FE003FFC000FFE003FFC000FFC003FF8001FF8001FF0003FF0001FC000FFE0
+000FF003FFC00007FFFFFF800003FFFFFE000001FFFFF80000007FFFE000000007FE0000
+002D427BC038>57 D<00000000FFF00000700000001FFFFF0000F0000001FFFFFFE001F0
+000007FFFFFFF803F000003FFFFFFFFE07F00000FFFFE001FF0FF00001FFFE00003F9FF0
+0007FFF000000FFFF0000FFFC0000007FFF0001FFF00000003FFF0003FFE00000001FFF0
+007FFC00000000FFF000FFF8000000007FF001FFF0000000003FF003FFE0000000001FF0
+07FFE0000000001FF007FFC0000000000FF00FFF80000000000FF00FFF800000000007F0
+1FFF000000000007F01FFF000000000003F03FFF000000000003F03FFE000000000003F0
+3FFE000000000003F07FFE000000000001F07FFE000000000001F07FFE000000000001F0
+7FFC00000000000000FFFC00000000000000FFFC00000000000000FFFC00000000000000
+FFFC00000000000000FFFC00000000000000FFFC00000000000000FFFC00000000000000
+FFFC00000000000000FFFC00000000000000FFFC00000000000000FFFC00000000000000
+FFFC00000000000000FFFC00000000000000FFFC000000000000007FFC00000000000000
+7FFE000000000000007FFE000000000000F07FFE000000000000F03FFE000000000000F0
+3FFE000000000000F03FFF000000000000F01FFF000000000001F01FFF000000000001E0
+0FFF800000000001E00FFF800000000003E007FFC00000000003C007FFE00000000007C0
+03FFE00000000007C001FFF0000000000F8000FFF8000000001F00007FFC000000003F00
+003FFE000000007E00001FFF80000000FC00000FFFC0000001F8000007FFF0000007F000
+0001FFFE00001FE0000000FFFFF001FF800000003FFFFFFFFF0000000007FFFFFFFC0000
+000001FFFFFFF000000000001FFFFF80000000000000FFF800000044467AC451>67
+D<FFFFFFFFFFFFFFF800FFFFFFFFFFFFFFF800FFFFFFFFFFFFFFF800FFFFFFFFFFFFFFF8
+00FFFFFFFFFFFFFFFC00001FFF000001FFFC00001FFF0000003FFC00001FFF0000000FFC
+00001FFF00000003FC00001FFF00000001FC00001FFF00000000FC00001FFF00000000FC
+00001FFF000000007E00001FFF000000003E00001FFF000000003E00001FFF000000003E
+00001FFF000000001E00001FFF000000001E00001FFF000078001E00001FFF000078001E
+00001FFF000078000F00001FFF000078000F00001FFF000078000F00001FFF000078000F
+00001FFF0000F8000000001FFF0000F8000000001FFF0000F8000000001FFF0001F80000
+00001FFF0003F8000000001FFF001FF8000000001FFFFFFFF8000000001FFFFFFFF80000
+00001FFFFFFFF8000000001FFFFFFFF8000000001FFFFFFFF8000000001FFF001FF80000
+00001FFF0003F8000000001FFF0001F8000000001FFF0000F8000000001FFF0000F80000
+00001FFF0000F80001E0001FFF0000780001E0001FFF0000780001E0001FFF0000780003
+C0001FFF0000780003C0001FFF0000780003C0001FFF0000780003C0001FFF0000000003
+C0001FFF0000000007C0001FFF0000000007C0001FFF000000000780001FFF0000000007
+80001FFF000000000F80001FFF000000000F80001FFF000000001F80001FFF000000001F
+80001FFF000000003F80001FFF000000007F00001FFF00000000FF00001FFF00000001FF
+00001FFF00000007FF00001FFF0000001FFF00001FFF000001FFFF00FFFFFFFFFFFFFFFF
+00FFFFFFFFFFFFFFFE00FFFFFFFFFFFFFFFE00FFFFFFFFFFFFFFFE00FFFFFFFFFFFFFFFE
+0043447DC34A>69 D<00000000FFF0000070000000001FFFFF0000F000000001FFFFFFE0
+01F000000007FFFFFFF803F00000003FFFFFFFFE07F0000000FFFFE001FF0FF0000001FF
+FE00003F9FF0000007FFF000000FFFF000000FFFC0000007FFF000001FFF00000003FFF0
+00003FFE00000001FFF000007FFC00000000FFF00000FFF8000000007FF00001FFF00000
+00003FF00003FFE0000000001FF00007FFE0000000001FF00007FFC0000000000FF0000F
+FF80000000000FF0000FFF800000000007F0001FFF000000000007F0001FFF0000000000
+03F0003FFF000000000003F0003FFE000000000003F0003FFE000000000003F0007FFE00
+0000000001F0007FFE000000000001F0007FFE000000000001F0007FFC00000000000000
+00FFFC0000000000000000FFFC0000000000000000FFFC0000000000000000FFFC000000
+0000000000FFFC0000000000000000FFFC0000000000000000FFFC0000000000000000FF
+FC0000000000000000FFFC0000000000000000FFFC0000000000000000FFFC0000000000
+000000FFFC0000000000000000FFFC0000000000000000FFFC0000007FFFFFFFF07FFC00
+00007FFFFFFFF07FFE0000007FFFFFFFF07FFE0000007FFFFFFFF07FFE0000007FFFFFFF
+F03FFE0000000001FFF0003FFE0000000001FFF0003FFF0000000001FFF0001FFF000000
+0001FFF0001FFF0000000001FFF0000FFF8000000001FFF0000FFF8000000001FFF00007
+FFC000000001FFF00007FFE000000001FFF00003FFE000000001FFF00001FFF000000001
+FFF00000FFF800000001FFF000007FFC00000001FFF000003FFE00000003FFF000001FFF
+80000003FFF000000FFFC0000007FFF0000007FFF000000FFFF0000001FFFE00003FFFF0
+000000FFFFF001FF9FF00000003FFFFFFFFF0FF000000007FFFFFFFC03F000000001FFFF
+FFF000F0000000001FFFFFC000300000000000FFFC000000004C467AC458>71
+D<FFFFFFFF800003FFFFF8FFFFFFFF800003FFFFF8FFFFFFFF800003FFFFF8FFFFFFFF80
+0003FFFFF8FFFFFFFF800003FFFFF8003FFE0000000007E000003FFE000000000FC00000
+3FFE000000001F8000003FFE000000007E0000003FFE00000000FC0000003FFE00000001
+F80000003FFE00000003F00000003FFE00000007E00000003FFE0000001F800000003FFE
+0000003F000000003FFE0000007E000000003FFE000000FC000000003FFE000001F80000
+00003FFE000007F0000000003FFE00000FC0000000003FFE00001F80000000003FFE0000
+3F00000000003FFE00007E00000000003FFE0001FC00000000003FFE0003F00000000000
+3FFE0007E000000000003FFE000FC000000000003FFE001FE000000000003FFE007FF000
+000000003FFE00FFF800000000003FFE01FFF800000000003FFE03FFFC00000000003FFE
+07FFFE00000000003FFE0FFFFF00000000003FFE3F3FFF00000000003FFE7E1FFF800000
+00003FFEFC1FFFC0000000003FFFF80FFFE0000000003FFFF007FFE0000000003FFFE003
+FFF0000000003FFF8003FFF8000000003FFF0001FFFC000000003FFE0000FFFC00000000
+3FFE00007FFE000000003FFE00007FFF000000003FFE00003FFF800000003FFE00001FFF
+800000003FFE00000FFFC00000003FFE00000FFFE00000003FFE000007FFF00000003FFE
+000003FFF00000003FFE000001FFF80000003FFE000001FFFC0000003FFE000000FFFE00
+00003FFE0000007FFE0000003FFE0000003FFF0000003FFE0000003FFF8000003FFE0000
+001FFFC000003FFE0000000FFFC000003FFE00000007FFE000003FFE00000007FFF00000
+3FFE00000003FFF800003FFE00000001FFF800FFFFFFFF8000FFFFFFFCFFFFFFFF8000FF
+FFFFFCFFFFFFFF8000FFFFFFFCFFFFFFFF8000FFFFFFFCFFFFFFFF8000FFFFFFFC4E447C
+C358>75 D<00000007FFC0000000000000FFFFFE000000000007FFFFFFC0000000001FFF
+FFFFF0000000007FFE00FFFC00000001FFF0001FFF00000007FF800003FFC000000FFF00
+0001FFE000001FFC0000007FF000003FF80000003FF800007FF00000001FFC0000FFF000
+00001FFE0001FFE00000000FFF0003FFC000000007FF8003FFC000000007FF8007FF8000
+000003FFC007FF8000000003FFC00FFF0000000001FFE00FFF0000000001FFE01FFF0000
+000001FFF01FFE0000000000FFF03FFE0000000000FFF83FFE0000000000FFF83FFE0000
+000000FFF87FFE0000000000FFFC7FFC00000000007FFC7FFC00000000007FFC7FFC0000
+0000007FFC7FFC00000000007FFCFFFC00000000007FFEFFFC00000000007FFEFFFC0000
+0000007FFEFFFC00000000007FFEFFFC00000000007FFEFFFC00000000007FFEFFFC0000
+0000007FFEFFFC00000000007FFEFFFC00000000007FFEFFFC00000000007FFEFFFC0000
+0000007FFEFFFC00000000007FFEFFFC00000000007FFE7FFC00000000007FFC7FFE0000
+000000FFFC7FFE0000000000FFFC7FFE0000000000FFFC3FFE0000000000FFF83FFE0000
+000000FFF83FFF0000000001FFF81FFF0000000001FFF01FFF0000000001FFF01FFF8000
+000003FFF00FFF8000000003FFE00FFF8000000003FFE007FFC000000007FFC003FFC000
+000007FF8003FFE00000000FFF8001FFF00000001FFF0000FFF80000003FFE00007FFC00
+00007FFC00003FFE000000FFF800001FFF000001FFF000000FFFC00007FFE0000007FFF0
+001FFFC0000001FFFE00FFFF00000000FFFFFFFFFE000000003FFFFFFFF80000000007FF
+FFFFC00000000000FFFFFE00000000000007FFC000000047467AC454>79
+D<FFFFFFFFFFF800000000FFFFFFFFFFFFC0000000FFFFFFFFFFFFF8000000FFFFFFFFFF
+FFFE000000FFFFFFFFFFFFFF800000001FFF00003FFFE00000001FFF000003FFF0000000
+1FFF000000FFF80000001FFF0000007FFC0000001FFF0000003FFE0000001FFF0000001F
+FF0000001FFF0000001FFF0000001FFF0000001FFF8000001FFF0000000FFF8000001FFF
+0000000FFF8000001FFF0000000FFFC000001FFF0000000FFFC000001FFF0000000FFFC0
+00001FFF0000000FFFC000001FFF0000000FFFC000001FFF0000000FFFC000001FFF0000
+000FFFC000001FFF0000000FFF8000001FFF0000000FFF8000001FFF0000001FFF000000
+1FFF0000001FFF0000001FFF0000003FFE0000001FFF0000003FFC0000001FFF0000007F
+FC0000001FFF000001FFF00000001FFF000007FFE00000001FFF00003FFF800000001FFF
+FFFFFFFF000000001FFFFFFFFFF8000000001FFFFFFFFFE0000000001FFFFFFFFFF80000
+00001FFF0000FFFC000000001FFF00003FFF000000001FFF00000FFF800000001FFF0000
+07FFC00000001FFF000003FFE00000001FFF000003FFE00000001FFF000001FFF0000000
+1FFF000001FFF00000001FFF000000FFF80000001FFF000000FFF80000001FFF000000FF
+F80000001FFF000000FFF80000001FFF000000FFF80000001FFF000000FFF80000001FFF
+000000FFF80000001FFF000000FFFC0000001FFF000000FFFC0000001FFF000000FFFC00
+00001FFF000000FFFC0000001FFF000000FFFC0000001FFF000000FFFC0000001FFF0000
+00FFFC000F001FFF000000FFFE000F001FFF000000FFFE000F001FFF0000007FFE000F00
+1FFF0000007FFF001F001FFF0000003FFF001EFFFFFFFFE0001FFF803EFFFFFFFFE0000F
+FFE0FCFFFFFFFFE00007FFFFF8FFFFFFFFE00001FFFFF0FFFFFFFFE000007FFFE0000000
+0000000007FF8050457DC354>82 D<0000FFE0001C000007FFFE003C00003FFFFF807C00
+00FFFFFFE0FC0001FFFFFFF9FC0003FF801FFFFC0007FC0001FFFC000FF800007FFC001F
+F000003FFC003FE000000FFC003FC0000007FC007FC0000003FC007F80000003FC007F80
+000001FC007F80000000FC00FF80000000FC00FF800000007C00FF800000007C00FFC000
+00007C00FFC00000007C00FFE00000003C00FFF00000003C00FFF80000003C00FFFC0000
+0000007FFE00000000007FFFE0000000007FFFFE000000003FFFFFF00000003FFFFFFF00
+00001FFFFFFFE000001FFFFFFFFC00000FFFFFFFFE000007FFFFFFFF800003FFFFFFFFC0
+0001FFFFFFFFE000007FFFFFFFF000001FFFFFFFF8000007FFFFFFFC000000FFFFFFFC00
+00000FFFFFFE00000000FFFFFE0000000007FFFF00000000007FFF00000000003FFF0000
+0000000FFF800000000007FF800000000003FF80F000000003FF80F000000001FF80F000
+000001FF80F000000000FF80F000000000FF80F800000000FF80F800000000FF80F80000
+0000FF00FC00000000FF00FC00000000FF00FE00000001FF00FF00000001FE00FF800000
+03FE00FFC0000003FC00FFE0000007FC00FFF800000FF800FFFF00003FF000FFFFF800FF
+E000FE7FFFFFFFC000FC1FFFFFFF0000F807FFFFFC0000F000FFFFF00000E00007FF8000
+0031467AC43E>I<0001FFE0000000001FFFFE000000007FFFFF80000001FFFFFFE00000
+03FE007FF8000007FC001FFC000007FE000FFE00000FFF0007FF00000FFF0007FF00000F
+FF0003FF80000FFF0003FF80000FFF0003FF80000FFF0001FFC00007FE0001FFC00003FC
+0001FFC00000F00001FFC00000000001FFC00000000001FFC00000000001FFC000000000
+01FFC000000003FFFFC0000000FFFFFFC0000007FFFFFFC000003FFFF1FFC00000FFFC01
+FFC00003FFE001FFC0000FFF8001FFC0001FFE0001FFC0003FFC0001FFC0003FF80001FF
+C0007FF80001FFC0007FF00001FFC000FFF00001FFC000FFE00001FFC000FFE00001FFC0
+00FFE00001FFC000FFE00003FFC000FFE00003FFC000FFF00007FFC0007FF8000FFFC000
+7FF8001FFFF0003FFE003EFFFFC01FFF80FC7FFFC007FFFFF87FFFC003FFFFE01FFFC000
+7FFF8007FFC0000FFC00000000322F7DAD36>97 D<007FC000000000FFFFC000000000FF
+FFC000000000FFFFC000000000FFFFC000000000FFFFC00000000003FFC00000000001FF
+C00000000001FFC00000000001FFC00000000001FFC00000000001FFC00000000001FFC0
+0000000001FFC00000000001FFC00000000001FFC00000000001FFC00000000001FFC000
+00000001FFC00000000001FFC00000000001FFC00000000001FFC00000000001FFC00000
+000001FFC00000000001FFC00FF8000001FFC0FFFF800001FFC3FFFFE00001FFCFFFFFF8
+0001FFDFC03FFC0001FFFF000FFE0001FFFC0003FF0001FFF80001FF8001FFF00001FFC0
+01FFE00000FFE001FFC00000FFE001FFC000007FF001FFC000007FF001FFC000007FF801
+FFC000003FF801FFC000003FF801FFC000003FF801FFC000003FFC01FFC000003FFC01FF
+C000003FFC01FFC000003FFC01FFC000003FFC01FFC000003FFC01FFC000003FFC01FFC0
+00003FFC01FFC000003FFC01FFC000003FFC01FFC000003FFC01FFC000003FFC01FFC000
+003FF801FFC000003FF801FFC000007FF801FFC000007FF001FFC000007FF001FFC00000
+7FF001FFC00000FFE001FFE00000FFC001FFF00001FFC001FFF80003FF8001FF7C0007FF
+0001FE3E000FFE0001FC1FC07FFC0001F80FFFFFF00001F003FFFFC00001E000FFFF0000
+0000001FF0000036467DC43E>I<00003FFC00000001FFFFC000000FFFFFF000003FFFFF
+FC00007FF003FE0000FFC001FF0003FF8003FF0007FF0007FF8007FE0007FF800FFE0007
+FF801FFC0007FF801FFC0007FF803FF80007FF803FF80003FF007FF80001FE007FF80000
+78007FF0000000007FF000000000FFF000000000FFF000000000FFF000000000FFF00000
+0000FFF000000000FFF000000000FFF000000000FFF000000000FFF000000000FFF00000
+0000FFF000000000FFF0000000007FF8000000007FF8000000007FF8000000003FF80000
+00003FFC000003C03FFC000003C01FFE000007C00FFE000007800FFF00000F8007FF8000
+1F0003FFC0003E0001FFF0007C00007FFC03F800003FFFFFF000000FFFFFC0000003FFFF
+000000003FF800002A2F7CAD32>I<0000000003FE0000000007FFFE0000000007FFFE00
+00000007FFFE0000000007FFFE0000000007FFFE00000000001FFE00000000000FFE0000
+0000000FFE00000000000FFE00000000000FFE00000000000FFE00000000000FFE000000
+00000FFE00000000000FFE00000000000FFE00000000000FFE00000000000FFE00000000
+000FFE00000000000FFE00000000000FFE00000000000FFE00000000000FFE0000000000
+0FFE0000003FE00FFE000003FFFC0FFE00000FFFFF8FFE00003FFFFFCFFE0000FFF807FF
+FE0001FFC001FFFE0003FF80007FFE0007FF00003FFE000FFE00001FFE000FFC00000FFE
+001FFC00000FFE003FF800000FFE003FF800000FFE003FF800000FFE007FF800000FFE00
+7FF000000FFE007FF000000FFE00FFF000000FFE00FFF000000FFE00FFF000000FFE00FF
+F000000FFE00FFF000000FFE00FFF000000FFE00FFF000000FFE00FFF000000FFE00FFF0
+00000FFE00FFF000000FFE00FFF000000FFE00FFF000000FFE007FF000000FFE007FF000
+000FFE007FF000000FFE007FF800000FFE003FF800000FFE003FF800000FFE001FFC0000
+1FFE001FFC00001FFE000FFE00003FFE0007FE00007FFE0003FF0000FFFF0001FFC003FF
+FFFC00FFF01FEFFFFC007FFFFF8FFFFC001FFFFE0FFFFC0007FFF80FFFFC00007FC00FF8
+0036467CC43E>I<00003FF800000003FFFF8000000FFFFFE000003FFFFFF000007FF83F
+F80000FFC007FC0001FF8003FE0003FF0001FF0007FE0000FF800FFC0000FF801FFC0000
+7FC01FF800007FC03FF800003FE03FF800003FE07FF800003FE07FF000003FE07FF00000
+3FF07FF000001FF0FFF000001FF0FFF000001FF0FFFFFFFFFFF0FFFFFFFFFFF0FFFFFFFF
+FFF0FFFFFFFFFFF0FFF000000000FFF000000000FFF000000000FFF000000000FFF00000
+00007FF0000000007FF0000000007FF8000000007FF8000000003FF8000000003FF80000
+00F01FFC000000F01FFC000001F00FFE000001E007FF000003E003FF800007C001FFC000
+0F8000FFF0003F00007FFE01FE00001FFFFFFC000007FFFFF0000001FFFFC00000001FFE
+00002C2F7DAD33>I<000000FF8000000FFFE000007FFFF00001FFFFF80003FF8FFC000F
+FE0FFE001FFC1FFE001FF81FFE003FF81FFE007FF01FFE007FF01FFE007FF00FFC00FFE0
+0FFC00FFE003F000FFE000C000FFE0000000FFE0000000FFE0000000FFE0000000FFE000
+0000FFE0000000FFE0000000FFE0000000FFE0000000FFE0000000FFE00000FFFFFFF800
+FFFFFFF800FFFFFFF800FFFFFFF800FFFFFFF80000FFE0000000FFE0000000FFE0000000
+FFE0000000FFE0000000FFE0000000FFE0000000FFE0000000FFE0000000FFE0000000FF
+E0000000FFE0000000FFE0000000FFE0000000FFE0000000FFE0000000FFE0000000FFE0
+000000FFE0000000FFE0000000FFE0000000FFE0000000FFE0000000FFE0000000FFE000
+0000FFE0000000FFE0000000FFE0000000FFE0000000FFE0000000FFE0000000FFE00000
+00FFE0000000FFE000007FFFFFE0007FFFFFE0007FFFFFE0007FFFFFE0007FFFFFE00027
+467DC522>I<0000FFE0007E00000FFFFE03FF80003FFFFF8FFF8000FFFFFFFFFFC001FF
+C07FFF3FC003FF001FF83FC007FE000FFC3FC00FFC0007FE1F801FFC0007FF0F001FF800
+03FF00001FF80003FF00003FF80003FF80003FF80003FF80003FF80003FF80003FF80003
+FF80003FF80003FF80003FF80003FF80003FF80003FF80003FF80003FF80001FF80003FF
+00001FF80003FF00001FFC0007FF00000FFC0007FE000007FE000FFC000003FF001FF800
+0001FFC07FF0000003FFFFFFE0000003FFFFFF800000078FFFFE0000000780FFE0000000
+0F8000000000000F8000000000000F8000000000000F8000000000000FC000000000000F
+E000000000000FF000000000000FFFFFFFC000000FFFFFFFFC000007FFFFFFFF800007FF
+FFFFFFE00003FFFFFFFFF00001FFFFFFFFFC0000FFFFFFFFFC0003FFFFFFFFFE000FFFFF
+FFFFFF001FF000007FFF003FC0000007FF007F80000001FF807F80000000FF80FF000000
+00FF80FF000000007F80FF000000007F80FF000000007F80FF000000007F80FF80000000
+FF807F80000000FF007FC0000001FF003FE0000003FE001FF0000007FC000FFE00003FF8
+0007FFC001FFF00001FFFFFFFFC000007FFFFFFF0000000FFFFFF8000000007FFF000000
+32427DAC38>I<007FC000000000FFFFC000000000FFFFC000000000FFFFC000000000FF
+FFC000000000FFFFC00000000003FFC00000000001FFC00000000001FFC00000000001FF
+C00000000001FFC00000000001FFC00000000001FFC00000000001FFC00000000001FFC0
+0000000001FFC00000000001FFC00000000001FFC00000000001FFC00000000001FFC000
+00000001FFC00000000001FFC00000000001FFC00000000001FFC00000000001FFC007FE
+000001FFC03FFF800001FFC0FFFFE00001FFC1FFFFF80001FFC7F03FFC0001FFCF801FFC
+0001FFDF000FFE0001FFDE000FFE0001FFFC000FFE0001FFF80007FF0001FFF00007FF00
+01FFF00007FF0001FFE00007FF0001FFE00007FF0001FFE00007FF0001FFC00007FF0001
+FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FF
+C00007FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC0
+0007FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC000
+07FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC00007
+FF0001FFC00007FF0001FFC00007FF0001FFC00007FF00FFFFFF83FFFFFEFFFFFF83FFFF
+FEFFFFFF83FFFFFEFFFFFF83FFFFFEFFFFFF83FFFFFE37457CC43E>I<007C0001FF0003
+FF8007FFC007FFC00FFFE00FFFE00FFFE00FFFE00FFFE007FFC007FFC003FF8001FF0000
+7C00000000000000000000000000000000000000000000000000000000000000007FC07F
+FFC07FFFC07FFFC07FFFC07FFFC003FFC001FFC001FFC001FFC001FFC001FFC001FFC001
+FFC001FFC001FFC001FFC001FFC001FFC001FFC001FFC001FFC001FFC001FFC001FFC001
+FFC001FFC001FFC001FFC001FFC001FFC001FFC001FFC001FFC001FFC001FFC001FFC001
+FFC001FFC001FFC0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF18467CC520>I<000003E00000
+0FF800001FFC00003FFE00003FFE00007FFF00007FFF00007FFF00007FFF00007FFF0000
+3FFE00003FFE00001FFC00000FF8000003E0000000000000000000000000000000000000
+00000000000000000000000000000000000000000000000001FF0003FFFF0003FFFF0003
+FFFF0003FFFF0003FFFF00000FFF000007FF000007FF000007FF000007FF000007FF0000
+07FF000007FF000007FF000007FF000007FF000007FF000007FF000007FF000007FF0000
+07FF000007FF000007FF000007FF000007FF000007FF000007FF000007FF000007FF0000
+07FF000007FF000007FF000007FF000007FF000007FF000007FF000007FF000007FF0000
+07FF000007FF000007FF000007FF000007FF000007FF000007FF000007FF000007FF0000
+07FF000007FF1F8007FF3FC007FF7FE007FFFFF007FFFFF00FFEFFF00FFEFFF00FFCFFF0
+1FFCFFE01FF87FE03FF03FC0FFE01FFFFF800FFFFF0003FFFC0000FFC000205A86C522>
+I<007FC000FFFFC000FFFFC000FFFFC000FFFFC000FFFFC00003FFC00001FFC00001FFC0
+0001FFC00001FFC00001FFC00001FFC00001FFC00001FFC00001FFC00001FFC00001FFC0
+0001FFC00001FFC00001FFC00001FFC00001FFC00001FFC00001FFC00001FFC00001FFC0
+0001FFC00001FFC00001FFC00001FFC00001FFC00001FFC00001FFC00001FFC00001FFC0
+0001FFC00001FFC00001FFC00001FFC00001FFC00001FFC00001FFC00001FFC00001FFC0
+0001FFC00001FFC00001FFC00001FFC00001FFC00001FFC00001FFC00001FFC00001FFC0
+0001FFC00001FFC00001FFC00001FFC00001FFC00001FFC00001FFC00001FFC00001FFC0
+0001FFC000FFFFFF80FFFFFF80FFFFFF80FFFFFF80FFFFFF8019457CC420>108
+D<007F8007FE00000FFC0000FFFF803FFFC0007FFF8000FFFF80FFFFF001FFFFE000FFFF
+81FFFFF803FFFFF000FFFF87F01FFC0FE03FF800FFFF8FC00FFE1F801FFC0003FF9F000F
+FF3E001FFE0001FF9E0007FF3C000FFE0001FFBC0007FF78000FFE0001FFF80003FFF000
+07FF0001FFF80003FFF00007FF0001FFF00003FFE00007FF0001FFE00003FFC00007FF00
+01FFE00003FFC00007FF0001FFE00003FFC00007FF0001FFC00003FF800007FF0001FFC0
+0003FF800007FF0001FFC00003FF800007FF0001FFC00003FF800007FF0001FFC00003FF
+800007FF0001FFC00003FF800007FF0001FFC00003FF800007FF0001FFC00003FF800007
+FF0001FFC00003FF800007FF0001FFC00003FF800007FF0001FFC00003FF800007FF0001
+FFC00003FF800007FF0001FFC00003FF800007FF0001FFC00003FF800007FF0001FFC000
+03FF800007FF0001FFC00003FF800007FF0001FFC00003FF800007FF0001FFC00003FF80
+0007FF0001FFC00003FF800007FF0001FFC00003FF800007FF0001FFC00003FF800007FF
+0001FFC00003FF800007FF0001FFC00003FF800007FF0001FFC00003FF800007FF0001FF
+C00003FF800007FF00FFFFFF81FFFFFF03FFFFFEFFFFFF81FFFFFF03FFFFFEFFFFFF81FF
+FFFF03FFFFFEFFFFFF81FFFFFF03FFFFFEFFFFFF81FFFFFF03FFFFFE572D7CAC5E>I<00
+7F8007FE0000FFFF803FFF8000FFFF80FFFFE000FFFF81FFFFF800FFFF87F03FFC00FFFF
+8F801FFC0003FF9F000FFE0001FF9E000FFE0001FFBC000FFE0001FFF80007FF0001FFF0
+0007FF0001FFF00007FF0001FFE00007FF0001FFE00007FF0001FFE00007FF0001FFC000
+07FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC00007
+FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC00007FF
+0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC00007FF00
+01FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001
+FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC00007FF00FFFFFF83FFFFFEFFFF
+FF83FFFFFEFFFFFF83FFFFFEFFFFFF83FFFFFEFFFFFF83FFFFFE372D7CAC3E>I<00001F
+FC0000000001FFFFC000000007FFFFF00000001FFFFFFC0000007FF80FFF000000FFC001
+FF800001FF8000FFC00003FE00003FE00007FE00003FF0000FFC00001FF8000FF800000F
+F8001FF800000FFC001FF800000FFC003FF800000FFE003FF0000007FE007FF0000007FF
+007FF0000007FF007FF0000007FF007FF0000007FF00FFF0000007FF80FFF0000007FF80
+FFF0000007FF80FFF0000007FF80FFF0000007FF80FFF0000007FF80FFF0000007FF80FF
+F0000007FF80FFF0000007FF80FFF0000007FF807FF0000007FF007FF0000007FF007FF0
+000007FF007FF0000007FF003FF800000FFE003FF800000FFE001FF800000FFC001FFC00
+001FFC000FFC00001FF80007FE00003FF00007FE00003FF00003FF8000FFE00001FFC001
+FFC000007FF80FFF0000003FFFFFFE0000000FFFFFF800000001FFFFC0000000001FFC00
+0000312F7DAD38>I<007FC00FF80000FFFFC0FFFF8000FFFFC3FFFFE000FFFFCFFFFFF8
+00FFFFDFC03FFC00FFFFFF001FFE0003FFFC0007FF0001FFF80003FF8001FFF00003FFC0
+01FFE00001FFE001FFC00001FFE001FFC00000FFF001FFC00000FFF001FFC000007FF801
+FFC000007FF801FFC000007FF801FFC000007FF801FFC000003FFC01FFC000003FFC01FF
+C000003FFC01FFC000003FFC01FFC000003FFC01FFC000003FFC01FFC000003FFC01FFC0
+00003FFC01FFC000003FFC01FFC000003FFC01FFC000003FFC01FFC000003FFC01FFC000
+007FF801FFC000007FF801FFC000007FF801FFC000007FF001FFC00000FFF001FFC00000
+FFF001FFC00001FFE001FFE00001FFC001FFF00003FFC001FFF80007FF8001FFFC000FFF
+0001FFFE001FFE0001FFDFC07FFC0001FFCFFFFFF00001FFC3FFFFC00001FFC0FFFF0000
+01FFC01FF0000001FFC00000000001FFC00000000001FFC00000000001FFC00000000001
+FFC00000000001FFC00000000001FFC00000000001FFC00000000001FFC00000000001FF
+C00000000001FFC00000000001FFC00000000001FFC000000000FFFFFF80000000FFFFFF
+80000000FFFFFF80000000FFFFFF80000000FFFFFF8000000036407DAC3E>I<007F807F
+00FFFF81FFE0FFFF83FFF0FFFF8FFFF8FFFF8F8FFCFFFF9F1FFE03FFBE1FFE01FFBC1FFE
+01FFF81FFE01FFF81FFE01FFF01FFE01FFF00FFC01FFE007F801FFE001E001FFE0000001
+FFE0000001FFE0000001FFC0000001FFC0000001FFC0000001FFC0000001FFC0000001FF
+C0000001FFC0000001FFC0000001FFC0000001FFC0000001FFC0000001FFC0000001FFC0
+000001FFC0000001FFC0000001FFC0000001FFC0000001FFC0000001FFC0000001FFC000
+0001FFC0000001FFC0000001FFC00000FFFFFFE000FFFFFFE000FFFFFFE000FFFFFFE000
+FFFFFFE000272D7DAC2E>114 D<001FFC038000FFFF878003FFFFFF800FFFFFFF801FF0
+03FF803FC000FF803F80003F807F00001F807E00001F80FE00000F80FE00000F80FE0000
+0780FF00000780FF00000780FF80000780FFE0000000FFFE0000007FFFF000007FFFFF00
+003FFFFFC0003FFFFFF0001FFFFFFC000FFFFFFE0003FFFFFF0001FFFFFF80007FFFFF80
+000FFFFFC000003FFFC0000003FFE0000000FFE0F000003FE0F000003FE0F800001FE0F8
+00000FE0F800000FE0FC00000FE0FC00000FE0FE00000FC0FF00001FC0FF00001FC0FF80
+003F80FFE0007F00FFF803FE00FFFFFFFC00FCFFFFF800F03FFFE000E007FE0000232F7C
+AD2C>I<0001E000000001E000000001E000000001E000000001E000000003E000000003
+E000000003E000000003E000000007E000000007E00000000FE00000000FE00000001FE0
+0000001FE00000003FE00000007FE0000000FFE0000003FFE000000FFFFFFF80FFFFFFFF
+80FFFFFFFF80FFFFFFFF80FFFFFFFF8000FFE0000000FFE0000000FFE0000000FFE00000
+00FFE0000000FFE0000000FFE0000000FFE0000000FFE0000000FFE0000000FFE0000000
+FFE0000000FFE0000000FFE0000000FFE0000000FFE0000000FFE0000000FFE0000000FF
+E0000000FFE0000000FFE0000000FFE001E000FFE001E000FFE001E000FFE001E000FFE0
+01E000FFE001E000FFE001E000FFE001E000FFE001E000FFE003E000FFF003C0007FF003
+C0007FF007C0003FF80F80001FFC1F00000FFFFF000007FFFC000001FFF80000003FE000
+23407EBE2C>I<007FC00001FF00FFFFC003FFFF00FFFFC003FFFF00FFFFC003FFFF00FF
+FFC003FFFF00FFFFC003FFFF0003FFC0000FFF0001FFC00007FF0001FFC00007FF0001FF
+C00007FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC0
+0007FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC000
+07FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC00007
+FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC00007FF
+0001FFC00007FF0001FFC00007FF0001FFC00007FF0001FFC0000FFF0001FFC0000FFF00
+01FFC0001FFF0001FFC0001FFF0001FFC0003FFF0000FFC0003FFF0000FFE0007FFF8000
+7FE001F7FFFE007FF807E7FFFE003FFFFFC7FFFE000FFFFF07FFFE0003FFFE07FFFE0000
+7FF007FC00372E7CAC3E>I<FFFFFF0003FFFCFFFFFF0003FFFCFFFFFF0003FFFCFFFFFF
+0003FFFCFFFFFF0003FFFC01FFE000003E0000FFE000003C0000FFF000003C00007FF000
+007800007FF800007800007FF80000F800003FF80000F000003FFC0001F000001FFC0001
+E000001FFE0003E000000FFE0003C000000FFF0007C0000007FF000780000007FF800F80
+000003FF800F00000003FFC00F00000003FFC01F00000001FFE01E00000001FFE03E0000
+0000FFE03C00000000FFF07C000000007FF078000000007FF8F8000000003FF8F0000000
+003FFDF0000000001FFDE0000000001FFFE0000000000FFFC0000000000FFFC000000000
+0FFFC00000000007FF800000000007FF800000000003FF000000000003FF000000000001
+FE000000000001FE000000000000FC000000000000FC00000000000078000000362C7EAB
+3B>I<FFFFFE1FFFFF801FFFF0FFFFFE1FFFFF801FFFF0FFFFFE1FFFFF801FFFF0FFFFFE
+1FFFFF801FFFF0FFFFFE1FFFFF801FFFF001FFC0003FE000007C0001FFC0003FF0000078
+0001FFE0003FF00000F80000FFE0001FF80000F00000FFF0001FF80001F000007FF0000F
+FC0001E000007FF0000FFC0001E000007FF8001FFC0003E000003FF8001FFE0003C00000
+3FFC003FFE0007C000001FFC003FFF00078000001FFC003FFF00078000001FFE0079FF00
+0F8000000FFE0079FF800F0000000FFF00F9FF801F00000007FF00F0FFC01E00000007FF
+80F0FFC01E00000003FF81E07FC03C00000003FF81E07FE03C00000003FFC3E07FE07C00
+000001FFC3C03FF07800000001FFE7C03FF07800000000FFE7801FF0F000000000FFE780
+1FF8F000000000FFFF801FF9F0000000007FFF000FFDE0000000007FFF000FFFE0000000
+003FFE0007FFC0000000003FFE0007FFC0000000003FFE0007FFC0000000001FFC0003FF
+80000000001FFC0003FF80000000000FF80001FF00000000000FF80001FF00000000000F
+F00000FF000000000007F00000FE000000000007F00000FE000000000003E000007C0000
+00000003C000003C0000004C2C7EAB51>I<FFFFFE003FFFF0FFFFFE003FFFF0FFFFFE00
+3FFFF0FFFFFE003FFFF0FFFFFE003FFFF000FFF00003E000007FF80007C000003FF8000F
+8000001FFC001F0000001FFE003F0000000FFF007E00000007FF807C00000003FFC0F800
+000001FFC1F000000001FFE3E000000000FFF7C0000000007FFF80000000003FFF800000
+00001FFF00000000001FFE00000000000FFF000000000007FF800000000003FFC0000000
+0003FFC00000000007FFE0000000000FFFF0000000000FFFF8000000001F3FFC00000000
+3E1FFC000000007C1FFE00000000F80FFF00000001F007FF80000003F003FFC0000007E0
+01FFC0000007C001FFE000000F8000FFF000001F00007FF800003E00003FFC00007E0000
+1FFC00FFFFE000FFFFFCFFFFE000FFFFFCFFFFE000FFFFFCFFFFE000FFFFFCFFFFE000FF
+FFFC362C7EAB3B>I E /Fi 6 104 df<7FFFFFFFFFFF80FFFFFFFFFFFFC0FFFFFFFFFFFF
+C07FFFFFFFFFFF803204799641>0 D<000FE000007FFC0000FFFE0003FFFF8007FFFFC0
+0FFFFFE01FFFFFF03FFFFFF83FFFFFF87FFFFFFC7FFFFFFC7FFFFFFCFFFFFFFEFFFFFFFE
+FFFFFFFEFFFFFFFEFFFFFFFEFFFFFFFEFFFFFFFEFFFFFFFE7FFFFFFC7FFFFFFC7FFFFFFC
+3FFFFFF83FFFFFF81FFFFFF00FFFFFE007FFFFC003FFFF8000FFFE00007FFC00000FE000
+1F207BA42A>15 D<00000000000180000000000007C000000000001FC000000000007F80
+0000000001FF000000000007FC00000000001FF000000000007FC00000000001FF000000
+000007FC00000000001FF000000000007FC00000000001FF000000000007FC0000000000
+1FF000000000007FC00000000001FF000000000007FC00000000001FF000000000007FC0
+0000000001FF000000000007FC00000000003FF000000000007FC00000000000FF000000
+000000FE0000000000007F8000000000003FE000000000000FF8000000000003FE000000
+000000FF8000000000003FE000000000000FF8000000000003FE000000000000FF800000
+0000003FE000000000000FF8000000000003FE000000000000FF8000000000003FE00000
+0000000FF8000000000003FE000000000000FF8000000000003FE000000000000FF80000
+00000003FE000000000000FF8000000000003FC000000000000FC0000000000003800000
+000000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000007FFFFFFFFFFF80FFFFFFFFFF
+FFC0FFFFFFFFFFFFC07FFFFFFFFFFF80324479B441>20 D<0000000000001E0000000000
+0000001E00000000000000001E00000000000000001E00000000000000001F0000000000
+0000000F00000000000000000F00000000000000000F8000000000000000078000000000
+00000007C00000000000000003E00000000000000003E00000000000000001F000000000
+00000000F80000000000000000FC00000000000000007E00000000000000003F00000000
+000000001F80000000000000000FC00000000000000007F07FFFFFFFFFFFFFFFFCFFFFFF
+FFFFFFFFFFFFFFFFFFFFFFFFFFFFFF7FFFFFFFFFFFFFFFFC0000000000000007F0000000
+000000000FC0000000000000001F80000000000000003F00000000000000007E00000000
+00000000FC0000000000000000F80000000000000001F00000000000000003E000000000
+00000003E00000000000000007C0000000000000000780000000000000000F8000000000
+0000000F00000000000000000F00000000000000001F00000000000000001E0000000000
+0000001E00000000000000001E00000000000000001E0000482C7BAA53>33
+D<000001F800000FF800003F800000FC000001F8000003F0000007E0000007E000000FE0
+00000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC0
+00000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC0
+00000FC000000FC000000FC000000FC000000FC000000FC000000FC000001FC000001F80
+00003F8000007F000000FE000003F800007FE00000FF0000007FE0000003F8000000FE00
+00007F0000003F8000001F8000001FC000000FC000000FC000000FC000000FC000000FC0
+00000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC0
+00000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC0
+00000FC000000FC000000FE0000007E0000007E0000003F0000001F8000000FC0000003F
+8000000FF8000001F81D537ABD2A>102 D<FC000000FFC0000007F0000001FC0000007E
+0000003F0000003F8000001F8000001FC000000FC000000FC000000FC000000FC000000F
+C000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000F
+C000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000F
+C000000FC000000FC000000FE0000007E0000007F0000003F8000001FC0000007E000000
+1FF0000007F800001FF000007E000001FC000003F8000007F0000007E000000FE000000F
+C000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000F
+C000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000F
+C000000FC000000FC000000FC000000FC000000FC000000FC000001FC000001F8000003F
+8000003F0000007E000001FC000007F00000FFC00000FC0000001D537ABD2A>I
+E /Fj 67 123 df<00000FF800FC0000007FFF07FF000001F807DF83C00007E001FF0FC0
+001F8007FE1FE0003F000FFC1FE0007E000FFC1FE0007E000FF81FE000FC000FF81FE000
+FC000FF0078001F80007F0000001F80003F0000001F80003F0000001F80003F0000001F8
+0003F0000001F80003F0000001F80003F0000001F80003F0000001F80003F0000001F800
+03F0000001F80003F0000001F80003F0000001F80003F00000FFFFFFFFFFF800FFFFFFFF
+FFF800FFFFFFFFFFF80001F80003F0000001F80003F0000001F80003F0000001F80003F0
+000001F80003F0000001F80003F0000001F80003F0000001F80003F0000001F80003F000
+0001F80003F0000001F80003F0000001F80003F0000001F80003F0000001F80003F00000
+01F80003F0000001F80003F0000001F80003F0000001F80003F0000001F80003F0000001
+F80003F0000001F80003F0000001F80003F0000001F80003F0000001F80003F0000001F8
+0003F0000001F80003F0000001F80003F0000001F80003F0000001F80003F0000003FC00
+07F800007FFFE0FFFFF0007FFFE0FFFFF0007FFFE0FFFFF000333B7FBA30>11
+D<00000FF8000000007FFE00000001F80780000007E001C000001F8000E000003F0007E0
+00007E000FF000007E000FF00000FC000FF00000FC000FF00001F8000FF00001F80007E0
+0001F80001800001F80000000001F80000000001F80000000001F80000000001F8000000
+0001F80000000001F80000000001F80000000001F80000000001F80003F000FFFFFFFFF0
+00FFFFFFFFF000FFFFFFFFF00001F8000FF00001F80003F00001F80003F00001F80003F0
+0001F80003F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003F0
+0001F80003F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003F0
+0001F80003F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003F0
+0001F80003F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003F0
+0001F80003F00003FC0007F8007FFFE0FFFFC07FFFE0FFFFC07FFFE0FFFFC02A3B7FBA2E
+>I<00000FFC000000007FFF70000001F803F0000007E007F000001F800FF000003F000F
+F000007E000FF000007E000FF00000FC000FF00000FC0007F00001F80003F00001F80003
+F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003
+F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003F000FFFFFFFF
+F000FFFFFFFFF000FFFFFFFFF00001F80003F00001F80003F00001F80003F00001F80003
+F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003
+F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003
+F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003
+F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003
+F00001F80003F00003FC0007F8007FFFE0FFFFC07FFFE0FFFFC07FFFE0FFFFC02A3B7FBA
+2E>I<00000FF0001FF0000000007FFE00FFFC00000001F80F83F00F00000007E001CFC0
+038000001F8000FF0001C000003F0007FE000FC000007E000FFC001FE000007E000FFC00
+1FE00000FC000FF8001FE00000FC000FF8001FE00001F8000FF0001FE00001F80007F000
+0FC00001F80003F00003000001F80003F00000000001F80003F00000000001F80003F000
+00000001F80003F00000000001F80003F00000000001F80003F00000000001F80003F000
+00000001F80003F00000000001F80003F00000000001F80003F00007E000FFFFFFFFFFFF
+FFE000FFFFFFFFFFFFFFE000FFFFFFFFFFFFFFE00001F80003F0001FE00001F80003F000
+07E00001F80003F00007E00001F80003F00007E00001F80003F00007E00001F80003F000
+07E00001F80003F00007E00001F80003F00007E00001F80003F00007E00001F80003F000
+07E00001F80003F00007E00001F80003F00007E00001F80003F00007E00001F80003F000
+07E00001F80003F00007E00001F80003F00007E00001F80003F00007E00001F80003F000
+07E00001F80003F00007E00001F80003F00007E00001F80003F00007E00001F80003F000
+07E00001F80003F00007E00001F80003F00007E00001F80003F00007E00001F80003F000
+07E00001F80003F00007E00001F80003F00007E00001F80003F00007E00003FC0007F800
+0FF0007FFFE0FFFFC1FFFF807FFFE0FFFFC1FFFF807FFFE0FFFFC1FFFF80413B7FBA45>
+I<1C007F00FF80FF80FFC0FFC0FFC07FC01CC000C000C000C000C001C001800180038003
+00070006000E001C003800700060000A1979B917>39 D<0000600000E00001C000038000
+0700000E00001E00003C0000780000780000F00001E00001E00003C00003C00007C00007
+80000F80000F00000F00001F00001E00001E00003E00003E00003E00007C00007C00007C
+00007C00007C00007C0000F80000F80000F80000F80000F80000F80000F80000F80000F8
+0000F80000F80000F80000F80000F80000F80000F80000F80000F800007C00007C00007C
+00007C00007C00007C00003E00003E00003E00001E00001E00001F00000F00000F00000F
+800007800007C00003C00003C00001E00001E00000F000007800007800003C00001E0000
+0E000007000003800001C00000E0000060135278BD20>I<C00000E00000700000380000
+1C00000E00000F000007800003C00003C00001E00000F00000F000007800007800007C00
+003C00003E00001E00001E00001F00000F00000F00000F80000F80000F800007C00007C0
+0007C00007C00007C00007C00003E00003E00003E00003E00003E00003E00003E00003E0
+0003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00007C00007C0
+0007C00007C00007C00007C0000F80000F80000F80000F00000F00001F00001E00001E00
+003E00003C00007C0000780000780000F00000F00001E00003C00003C0000780000F0000
+0E00001C0000380000700000E00000C0000013527CBD20>I<1C007F00FF80FF80FFC0FF
+C0FFC07FC01CC000C000C000C000C001C00180018003800300070006000E001C00380070
+0060000A19798817>44 D<FFFFFCFFFFFCFFFFFCFFFFFCFFFFFC16057F941C>I<1C007F
+00FF80FF80FF80FF80FF807F001C000909798817>I<0003F80000001FFF0000007E0FC0
+0000F803E00001E000F00003C000780007C0007C000F80003E000F80003E001F00001F00
+1F00001F003F00001F803F00001F803F00001F807E00000FC07E00000FC07E00000FC07E
+00000FC07E00000FC07E00000FC0FE00000FE0FE00000FE0FE00000FE0FE00000FE0FE00
+000FE0FE00000FE0FE00000FE0FE00000FE0FE00000FE0FE00000FE0FE00000FE0FE0000
+0FE0FE00000FE0FE00000FE0FE00000FE0FE00000FE0FE00000FE0FE00000FE0FE00000F
+E07E00000FC07E00000FC07E00000FC07E00000FC07F00001FC03F00001F803F00001F80
+3F00001F801F00001F001F80003F000F80003E000F80003E0007C0007C0003E000F80001
+F001F00000F803E000007E0FC000001FFF00000003F80000233A7DB72A>48
+D<0001C0000003C0000007C000001FC00000FFC000FFFFC000FFFFC000FF1FC000001FC0
+00001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC0
+00001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC0
+00001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC0
+00001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC0
+00001FC000001FC000001FC000001FC000001FC000001FC000001FC000003FE0007FFFFF
+F07FFFFFF07FFFFFF01C3879B72A>I<000FF00000007FFE000001FFFF800003E03FE000
+0F000FF0000E0007F8001C0003FC00380001FE00300001FE00700000FF00600000FF00FC
+0000FF00FF00007F80FF80007F80FF80007F80FF80007F80FF80007F80FF80007F807F00
+007F801C00007F800000007F80000000FF00000000FF00000000FF00000001FE00000001
+FC00000003FC00000003F800000007F000000007E00000000FE00000001FC00000003F80
+0000003F000000007C00000000F800000001F000000003E000000007C00000000F800000
+000F000000001E000180003C000180007800018000F000038001E000030003C000030007
+800003000E000007000FFFFFFF001FFFFFFF003FFFFFFF007FFFFFFE00FFFFFFFE00FFFF
+FFFE00FFFFFFFE0021387CB72A>I<0007F80000003FFF0000007FFFC00001F80FF00003
+C007F800078003FC000E0001FC000F0001FE001FE000FE001FF000FF001FF000FF001FF0
+00FF001FF000FF001FF000FF000FE000FF0007C000FF00000000FE00000001FE00000001
+FE00000001FC00000003F800000003F800000007F000000007E00000000F800000007E00
+00001FFC0000001FFF800000000FE000000007F000000001FC00000001FE00000000FF00
+0000007F800000007F800000007FC00000007FC00000003FC00000003FE00000003FE01E
+00003FE07F80003FE0FFC0003FE0FFC0003FE0FFC0003FE0FFC0003FE0FFC0003FC0FF80
+007FC07F80007F807E00007F80700000FF00380001FE001E0001FE000F8003F80007F00F
+F00001FFFFC000007FFF0000000FF80000233A7DB72A>I<000000380000000038000000
+007800000000F800000000F800000001F800000003F800000007F800000007F80000000F
+F80000001FF80000001BF800000033F800000073F800000063F8000000C3F8000001C3F8
+00000183F800000303F800000703F800000603F800000C03F800001C03F800001803F800
+003003F800007003F800006003F80000C003F80001C003F800038003F800030003F80007
+0003F8000E0003F8000C0003F800180003F800380003F800300003F800600003F800E000
+03F800FFFFFFFFF8FFFFFFFFF8FFFFFFFFF8000003F800000003F800000003F800000003
+F800000003F800000003F800000003F800000003F800000003F800000003F800000003F8
+00000007FC000003FFFFF80003FFFFF80003FFFFF825397EB82A>I<0600000C00078000
+3C0007F003F80007FFFFF80007FFFFF00007FFFFE00007FFFF800007FFFF000007FFFC00
+00067FE00000060000000006000000000600000000060000000006000000000600000000
+060000000006000000000600000000060000000006000000000607F80000063FFE000006
+780F800007E007E000078003F000070001F800060001F800060000FC00000000FE000000
+00FE00000000FF000000007F000000007F000000007F800000007F800000007F80000000
+7F803E00007F807F00007F80FF80007F80FF80007F80FF80007F80FF80007F80FF00007F
+00FE0000FF00E00000FF00600000FE00700000FE00300001FC00380001F8001C0003F800
+1E0007F0000F800FE00007E03F800001FFFF0000007FFC0000001FE00000213A7CB72A>
+I<00003FC0000001FFF0000007FFFC00000FE03E00003F800700007E001F0000FC003F80
+01F8007F8003F0007F8003F0007F8007E0007F800FE0003F000FC0001E001FC00000001F
+C00000003F800000003F800000003F800000007F800000007F000000007F01FC00007F07
+FF8000FF1E07E000FF3801F000FF7000F800FF6000FC00FFE0007E00FFC0003F00FFC000
+3F00FF80003F80FF80003FC0FF80001FC0FF80001FC0FF00001FE0FF00001FE0FF00001F
+E0FF00001FE0FF00001FE07F00001FE07F00001FE07F00001FE07F00001FE07F00001FE0
+3F80001FE03F80001FC03F80001FC01F80001FC01F80003F801FC0003F800FC0003F0007
+E0007F0007E000FE0003F000FC0001F801F80000FE07F000003FFFC000001FFF00000003
+FC0000233A7DB72A>I<300000000038000000003E000000003FFFFFFFE03FFFFFFFE03F
+FFFFFFE03FFFFFFFC07FFFFFFFC07FFFFFFF807FFFFFFF0070000006006000000E006000
+001C006000001800E000003800C000007000C00000E000C00000C000000001C000000003
+80000000030000000007000000000E000000000C000000001C0000000038000000003800
+00000070000000007000000000F000000001E000000001E000000003E000000003E00000
+0003C000000007C000000007C00000000FC00000000FC00000000FC00000001F80000000
+1F800000001F800000003F800000003F800000003F800000003F800000003F800000007F
+800000007F800000007F800000007F800000007F800000007F800000007F800000007F80
+0000007F800000003F000000001E000000233B7BB82A>I<0003F80000001FFF0000007F
+FFC00000FC07F00001E001F80003C000FC000780007C000700003E000F00001E000E0000
+1F001E00000F001E00000F001E00000F001F00000F001F00000F001F80000F001F80001F
+001FE0001E000FF0003E000FFC003C000FFE00780007FF80F00007FFC1E00003FFF3C000
+01FFFF000000FFFE0000003FFF0000001FFFC000001FFFE000007FFFF80000F0FFFC0003
+E07FFE0007801FFF000F000FFF801F0003FF803E0001FFC03C00007FC07C00003FC07800
+000FE0F8000007E0F0000007E0F0000003E0F0000003E0F0000001E0F0000001E0F00000
+01E0F8000001C078000001C078000003C07C000003803E000007001F00000F000F80001E
+0007E0007C0003F803F00000FFFFE000003FFF80000007FC0000233A7DB72A>I<0003F8
+0000001FFF0000007FFFC00000FC07E00003F803F00007F001F8000FE000FC000FC0007E
+001FC0007E003F80003F003F80003F007F80003F807F00003F807F00003F80FF00001FC0
+FF00001FC0FF00001FC0FF00001FC0FF00001FC0FF00001FC0FF00001FE0FF00001FE0FF
+00001FE0FF00001FE0FF00001FE07F00003FE07F00003FE07F80003FE03F80003FE01F80
+007FE01F80007FE00FC000FFE007E000DFE003E001DFE001F0039FE000FC0F1FE0003FFC
+1FC00007F01FC00000001FC00000003FC00000003F800000003F800000003F800000003F
+000000007F000F00007E001F80007E003FC000FC003FC000FC003FC001F8003FC003F000
+3F8007E0001F000FC0001C001F80000F807F000007FFFC000001FFF00000003FC0000023
+3A7DB72A>I<1C007F00FF80FF80FF80FF80FF807F001C00000000000000000000000000
+0000000000000000000000000000000000000000000000001C007F00FF80FF80FF80FF80
+FF807F001C00092479A317>I<1C007F00FF80FF80FF80FF80FF807F001C000000000000
+000000000000000000000000000000000000000000000000000000000000001C007F00FF
+00FF80FF80FF80FF807F801D8001800180018001800380030003000700060006000E001C
+001800380070006000093479A317>I<0000003800000000000038000000000000380000
+000000007C0000000000007C0000000000007C000000000000FE000000000000FE000000
+000000FE000000000001FF000000000001FF000000000001FF0000000000037F80000000
+00037F8000000000077FC000000000063FC000000000063FC0000000000E3FE000000000
+0C1FE0000000000C1FE0000000001C1FF000000000180FF000000000180FF00000000038
+0FF8000000003007F8000000003007F8000000007007FC000000006003FC000000006003
+FC00000000C003FE00000000C001FE00000000C001FE000000018001FF000000018000FF
+000000018000FF000000030000FF8000000300007F8000000300007F8000000600007FC0
+000007FFFFFFC0000007FFFFFFC000000FFFFFFFE000000C00001FE000000C00001FE000
+001800000FF000001800000FF000001800000FF0000030000007F8000030000007F80000
+30000007F8000060000003FC000060000003FC0000E0000003FC0000E0000001FE0001E0
+000001FE0003F0000001FF000FFC000007FF80FFFF8000FFFFFEFFFF8000FFFFFEFFFF80
+00FFFFFE373C7DBB3E>65 D<000001FF80018000000FFFE0038000007FFFF803800001FF
+807E07800003FC000F0F80000FF000039F80001FE00001DF80003F800000FF80007F0000
+007F8000FE0000003F8001FE0000003F8003FC0000001F8007F80000000F8007F8000000
+0F800FF000000007800FF000000007801FE000000007801FE000000003803FE000000003
+803FC000000003807FC000000001807FC000000001807FC000000001807F800000000180
+FF800000000000FF800000000000FF800000000000FF800000000000FF800000000000FF
+800000000000FF800000000000FF800000000000FF800000000000FF800000000000FF80
+0000000000FF800000000000FF8000000000007F8000000000007FC000000001807FC000
+000001807FC000000001803FC000000001803FE000000001801FE000000003801FE00000
+0003000FF000000003000FF0000000070007F8000000070007F8000000060003FC000000
+0E0001FE0000001C0000FE0000001800007F0000003800003F8000007000001FE00000E0
+00000FF00003C0000003FC000F80000001FF803F000000007FFFFC000000000FFFF00000
+000001FF800000313D7BBA3C>67 D<FFFFFFFFFFFC00FFFFFFFFFFFC00FFFFFFFFFFFC00
+01FF80000FFC0000FF000001FC0000FF0000007E0000FF0000003E0000FF0000001E0000
+FF0000000E0000FF0000000E0000FF0000000E0000FF000000060000FF000000060000FF
+000000060000FF000000070000FF000000030000FF0000C0030000FF0000C0030000FF00
+00C0030000FF0000C0000000FF0000C0000000FF0000C0000000FF0001C0000000FF0001
+C0000000FF0003C0000000FF000FC0000000FFFFFFC0000000FFFFFFC0000000FFFFFFC0
+000000FF000FC0000000FF0003C0000000FF0001C0000000FF0001C0000000FF0000C000
+0000FF0000C0000000FF0000C0006000FF0000C0006000FF0000C0006000FF0000C000E0
+00FF00000000C000FF00000000C000FF00000000C000FF00000000C000FF00000001C000
+FF00000001C000FF00000001C000FF000000038000FF000000038000FF000000078000FF
+000000078000FF0000000F8000FF0000003F8000FF0000007F8001FF800007FF00FFFFFF
+FFFFFF00FFFFFFFFFFFF00FFFFFFFFFFFF0033397DB839>69 D<FFFFFFFFFFF8FFFFFFFF
+FFF8FFFFFFFFFFF801FF80001FF800FF000001F800FF000000FC00FF0000007C00FF0000
+003C00FF0000001C00FF0000001C00FF0000000C00FF0000000C00FF0000000C00FF0000
+000C00FF0000000E00FF0000000600FF0000000600FF0001800600FF0001800600FF0001
+800000FF0001800000FF0001800000FF0001800000FF0003800000FF0003800000FF0007
+800000FF001F800000FFFFFF800000FFFFFF800000FFFFFF800000FF001F800000FF0007
+800000FF0003800000FF0003800000FF0001800000FF0001800000FF0001800000FF0001
+800000FF0001800000FF0001800000FF0000000000FF0000000000FF0000000000FF0000
+000000FF0000000000FF0000000000FF0000000000FF0000000000FF0000000000FF0000
+000000FF0000000000FF0000000000FF0000000001FFC0000000FFFFFFC00000FFFFFFC0
+0000FFFFFFC000002F397DB836>I<000000FF8000C000000FFFF001C000003FFFFC01C0
+0000FF803F03C00003FC000787C0000FF00003CFC0001FE00000EFC0003FC000007FC000
+7F8000003FC000FF0000001FC001FE0000001FC003FC0000000FC007F800000007C007F8
+00000007C00FF000000003C00FF000000003C01FE000000003C01FE000000001C03FE000
+000001C03FC000000001C07FC000000000C07FC000000000C07FC000000000C07FC00000
+0000C0FF800000000000FF800000000000FF800000000000FF800000000000FF80000000
+0000FF800000000000FF800000000000FF800000000000FF800000000000FF8000000000
+00FF800000000000FF800000FFFFFFFF800000FFFFFF7FC00000FFFFFF7FC00000007FE0
+7FC00000003FC07FC00000003FC03FC00000003FC03FE00000003FC01FE00000003FC01F
+E00000003FC00FF00000003FC00FF00000003FC007F80000003FC007F80000003FC003FC
+0000003FC001FE0000003FC000FF0000007FC0007F8000007FC0003FC00000FFC0001FE0
+0000EFC0000FF80003C7C00003FE000783C00000FFC03F01C000003FFFFC00C000000FFF
+F00000000000FF800000383D7CBA41>I<FFFFFFC0FFFFFFC0FFFFFFC000FFC000007F80
+00007F8000007F8000007F8000007F8000007F8000007F8000007F8000007F8000007F80
+00007F8000007F8000007F8000007F8000007F8000007F8000007F8000007F8000007F80
+00007F8000007F8000007F8000007F8000007F8000007F8000007F8000007F8000007F80
+00007F8000007F8000007F8000007F8000007F8000007F8000007F8000007F8000007F80
+00007F8000007F8000007F8000007F8000007F8000007F8000007F8000007F8000007F80
+00007F8000007F8000007F800000FFC000FFFFFFC0FFFFFFC0FFFFFFC01A397EB81E>73
+D<FFFFFF0001FFFF00FFFFFF0001FFFF00FFFFFF0001FFFF0001FF8000007FF00000FF00
+00003F800000FF0000003E000000FF0000003C000000FF00000038000000FF0000007000
+0000FF000000E0000000FF000001C0000000FF00000380000000FF00000700000000FF00
+000E00000000FF00001C00000000FF00003800000000FF00007000000000FF0000E00000
+0000FF0001C000000000FF00078000000000FF000E0000000000FF001C0000000000FF00
+3E0000000000FF007E0000000000FF00FF0000000000FF01FF0000000000FF03FF800000
+0000FF077FC000000000FF0E7FC000000000FF1C3FE000000000FF381FF000000000FF70
+1FF000000000FFE00FF800000000FFC007FC00000000FF8007FC00000000FF0003FE0000
+0000FF0001FF00000000FF0001FF00000000FF0000FF80000000FF00007FC0000000FF00
+007FC0000000FF00003FE0000000FF00001FF0000000FF00001FF0000000FF00000FF800
+0000FF00000FF8000000FF000007FC000000FF000003FE000000FF000003FE000000FF00
+0001FF000000FF000000FF800000FF000000FFC00000FF000000FFE00001FF800001FFF0
+00FFFFFF001FFFFF80FFFFFF001FFFFF80FFFFFF001FFFFF8039397DB841>75
+D<FFFFFFE00000FFFFFFE00000FFFFFFE0000001FFC000000000FF0000000000FF000000
+0000FF0000000000FF0000000000FF0000000000FF0000000000FF0000000000FF000000
+0000FF0000000000FF0000000000FF0000000000FF0000000000FF0000000000FF000000
+0000FF0000000000FF0000000000FF0000000000FF0000000000FF0000000000FF000000
+0000FF0000000000FF0000000000FF0000000000FF0000000000FF0000000000FF000000
+0000FF0000000000FF0000000000FF0000000000FF0000000000FF0000000000FF000000
+1800FF0000001800FF0000001800FF0000001800FF0000001800FF0000003800FF000000
+3000FF0000003000FF0000003000FF0000007000FF0000007000FF0000007000FF000000
+F000FF000000F000FF000001F000FF000003F000FF00000FF000FF00001FE001FF8000FF
+E0FFFFFFFFFFE0FFFFFFFFFFE0FFFFFFFFFFE02D397DB834>I<FFFF0000000007FFF8FF
+FF800000000FFFF8FFFF800000000FFFF801FF800000000FFC0000DFC00000001BF80000
+DFC00000001BF80000CFE000000033F80000CFE000000033F80000CFE000000033F80000
+C7F000000063F80000C7F000000063F80000C7F000000063F80000C3F8000000C3F80000
+C3F8000000C3F80000C1FC00000183F80000C1FC00000183F80000C1FC00000183F80000
+C0FE00000303F80000C0FE00000303F80000C07F00000603F80000C07F00000603F80000
+C07F00000603F80000C03F80000C03F80000C03F80000C03F80000C03F80000C03F80000
+C01FC0001803F80000C01FC0001803F80000C00FE0003003F80000C00FE0003003F80000
+C00FE0003003F80000C007F0006003F80000C007F0006003F80000C003F800C003F80000
+C003F800C003F80000C003F800C003F80000C001FC018003F80000C001FC018003F80000
+C001FC018003F80000C000FE030003F80000C000FE030003F80000C0007F060003F80000
+C0007F060003F80000C0007F060003F80000C0003F8C0003F80000C0003F8C0003F80000
+C0001FD80003F80000C0001FD80003F80000C0001FD80003F80000C0000FF00003F80000
+C0000FF00003F80000C0000FF00003F80001E00007E00003F80003F00007E00003F8000F
+FC0003C00007FC00FFFFC003C003FFFFF8FFFFC003C003FFFFF8FFFFC0018003FFFFF845
+397DB84C>I<FFFF000007FFFEFFFF800007FFFEFFFFC00007FFFE00FFC000007FE000FF
+E000001F8000DFF000000F0000DFF00000060000CFF80000060000C7FC0000060000C7FC
+0000060000C3FE0000060000C1FF0000060000C1FF0000060000C0FF8000060000C07FC0
+00060000C07FC000060000C03FE000060000C01FF000060000C01FF800060000C00FF800
+060000C007FC00060000C007FE00060000C003FE00060000C001FF00060000C001FF8006
+0000C000FF80060000C0007FC0060000C0007FE0060000C0003FE0060000C0001FF00600
+00C0000FF8060000C0000FF8060000C00007FC060000C00003FE060000C00003FE060000
+C00001FF060000C00000FF860000C00000FF860000C000007FC60000C000003FE60000C0
+00003FE60000C000001FF60000C000000FFE0000C000000FFE0000C0000007FE0000C000
+0003FE0000C0000003FE0000C0000001FE0000C0000000FE0000C0000000FE0000C00000
+007E0001E00000003E0003F00000003E000FFC0000001E00FFFFC000000E00FFFFC00000
+0E00FFFFC00000060037397DB83E>I<000003FF00000000001FFFE000000000FE01FC00
+000001F8007E00000007E0001F8000000FC0000FC000003F800007F000007F000003F800
+00FE000001FC0001FC000000FE0001F80000007E0003F80000007F0007F00000003F8007
+F00000003F800FE00000001FC00FE00000001FC01FE00000001FE01FC00000000FE03FC0
+0000000FF03FC00000000FF03FC00000000FF07FC00000000FF87F8000000007F87F8000
+000007F87F8000000007F8FF8000000007FCFF8000000007FCFF8000000007FCFF800000
+0007FCFF8000000007FCFF8000000007FCFF8000000007FCFF8000000007FCFF80000000
+07FCFF8000000007FCFF8000000007FCFF8000000007FC7F8000000007F87FC00000000F
+F87FC00000000FF87FC00000000FF83FC00000000FF03FC00000000FF01FE00000001FE0
+1FE00000001FE01FE00000001FE00FF00000003FC007F00000003F8007F80000007F8003
+F80000007F0001FC000000FE0001FC000000FE0000FE000001FC00007F000003F800003F
+800007F000001FC0000FE0000007E0001F80000003F8007F00000000FE01FC000000001F
+FFE00000000003FF000000363D7BBA41>I<FFFFFFFFC000FFFFFFFFF800FFFFFFFFFE00
+01FF8001FF8000FF00003FC000FF00000FE000FF000007F000FF000003F800FF000003FC
+00FF000003FE00FF000001FE00FF000001FE00FF000001FF00FF000001FF00FF000001FF
+00FF000001FF00FF000001FF00FF000001FF00FF000001FF00FF000001FE00FF000001FE
+00FF000003FC00FF000003FC00FF000007F800FF000007F000FF00000FE000FF00003FC0
+00FF0001FF0000FFFFFFFC0000FFFFFFF00000FF0000000000FF0000000000FF00000000
+00FF0000000000FF0000000000FF0000000000FF0000000000FF0000000000FF00000000
+00FF0000000000FF0000000000FF0000000000FF0000000000FF0000000000FF00000000
+00FF0000000000FF0000000000FF0000000000FF0000000000FF0000000000FF00000000
+00FF0000000000FF0000000001FF80000000FFFFFF000000FFFFFF000000FFFFFF000000
+30397DB839>I<FFFFFFFE00000000FFFFFFFFE0000000FFFFFFFFF800000001FF8007FE
+00000000FF0000FF80000000FF00003FC0000000FF00001FE0000000FF00000FF0000000
+FF000007F8000000FF000007F8000000FF000003FC000000FF000003FC000000FF000003
+FE000000FF000003FE000000FF000003FE000000FF000003FE000000FF000003FE000000
+FF000003FE000000FF000003FC000000FF000003FC000000FF000007F8000000FF000007
+F8000000FF00000FF0000000FF00001FE0000000FF00003F80000000FF0000FF00000000
+FF0007FC00000000FFFFFFE000000000FFFFFFC000000000FF000FF000000000FF0003F8
+00000000FF0000FE00000000FF0000FF00000000FF00007F80000000FF00003FC0000000
+FF00003FC0000000FF00001FC0000000FF00001FE0000000FF00001FE0000000FF00001F
+E0000000FF00001FE0000000FF00001FE0000000FF00001FF0000000FF00001FF0000000
+FF00001FF0000000FF00001FF0000000FF00001FF0000000FF00001FF0000000FF00001F
+F0018000FF00001FF0018000FF00001FF8018000FF00000FF8018000FF00000FF8038001
+FF800007F80300FFFFFF0003FC0700FFFFFF0001FC0600FFFFFF0000FE0E000000000000
+3FFC00000000000007F000393B7DB83D>82 D<000FF800C0003FFE01C000FFFF81C003F8
+07E3C007E000F7C00FC0007FC01F80003FC03F00001FC03E00000FC07E000007C07E0000
+07C07C000003C0FC000003C0FC000001C0FC000001C0FC000001C0FE000000C0FE000000
+C0FE000000C0FF000000C0FF800000007FC00000007FE00000007FF80000003FFF800000
+1FFFF800001FFFFF80000FFFFFE00007FFFFF80003FFFFFE0000FFFFFF00003FFFFF8000
+07FFFFC000007FFFC0000007FFE00000007FE00000003FF00000001FF00000000FF00000
+0007F800000007F8C0000003F8C0000003F8C0000001F8C0000001F8C0000001F8E00000
+01F8E0000001F8E0000001F0F0000001F0F0000003F0F8000003E0FC000007E0FE000007
+C0FF00000FC0FF80001F80FBF0003F00F0FE00FE00E03FFFF800E00FFFE000C001FF0000
+253D7CBA2E>I<3FFFFFFFFFFFE03FFFFFFFFFFFE03FFFFFFFFFFFE03FC003FF001FE03E
+0001FE0003E07C0001FE0001F0780001FE0000F0700001FE000070700001FE0000707000
+01FE000070600001FE000030600001FE000030600001FE000030600001FE000030E00001
+FE000038C00001FE000018C00001FE000018C00001FE000018C00001FE000018000001FE
+000000000001FE000000000001FE000000000001FE000000000001FE000000000001FE00
+0000000001FE000000000001FE000000000001FE000000000001FE000000000001FE0000
+00000001FE000000000001FE000000000001FE000000000001FE000000000001FE000000
+000001FE000000000001FE000000000001FE000000000001FE000000000001FE00000000
+0001FE000000000001FE000000000001FE000000000001FE000000000001FE0000000000
+01FE000000000001FE000000000001FE000000000001FE000000000001FE000000000001
+FE000000000001FE000000000001FE000000000007FF800000001FFFFFFFE000001FFFFF
+FFE000001FFFFFFFE00035397DB83C>I<FFFFFF0007FFFEFFFFFF0007FFFEFFFFFF0007
+FFFE01FF8000007FE000FF0000001F8000FF0000000F0000FF000000060000FF00000006
+0000FF000000060000FF000000060000FF000000060000FF000000060000FF0000000600
+00FF000000060000FF000000060000FF000000060000FF000000060000FF000000060000
+FF000000060000FF000000060000FF000000060000FF000000060000FF000000060000FF
+000000060000FF000000060000FF000000060000FF000000060000FF000000060000FF00
+0000060000FF000000060000FF000000060000FF000000060000FF000000060000FF0000
+00060000FF000000060000FF000000060000FF000000060000FF000000060000FF000000
+060000FF000000060000FF000000060000FF000000060000FF0000000E00007F0000000C
+00007F8000000C00007F8000001C00003F8000001C00003F8000001800001FC000003800
+001FC000007000000FE00000F0000007F00000E0000003F80001C0000001FC0007800000
+00FE000F000000007F807E000000001FFFF80000000007FFE000000000007F800000373B
+7DB83E>I<FFFFFC00007FFF80FFFFFC00007FFF80FFFFFC00007FFF8003FF8000000FFC
+0001FF00000007E00001FF00000003C00000FF00000001800000FF800000038000007F80
+0000030000007F800000030000007FC00000030000003FC00000060000003FC000000600
+00003FE000000E0000001FE000000C0000001FF000000C0000000FF00000180000000FF0
+0000180000000FF800001800000007F800003000000007F800003000000007FC00007000
+000003FC00006000000003FC00006000000001FE0000C000000001FE0000C000000001FF
+0000C000000000FF00018000000000FF00018000000000FF800380000000007F80030000
+0000007F800300000000003FC00600000000003FC00600000000003FE00600000000001F
+E00C00000000001FE00C00000000001FF01C00000000000FF01800000000000FF0180000
+00000007F830000000000007F830000000000007FC30000000000003FC60000000000003
+FC60000000000003FEE0000000000001FEC0000000000001FEC0000000000000FF800000
+00000000FF80000000000000FF800000000000007F000000000000007F00000000000000
+7F000000000000003E000000000000003E000000000000001C000000000000001C000000
+000000001C00000000393B7EB83E>I<FFFFFC07FFFFF001FFFFFFFFFC07FFFFF001FFFF
+FFFFFC07FFFFF001FFFF07FF80001FFE00001FF803FE00000FF8000007E001FE000007F8
+000003C001FE000007F80000038001FF000007F80000038000FF000003FC0000030000FF
+000003FC0000030000FF800003FC00000700007F800001FE00000600007F800001FE0000
+0600007FC00001FE00000600003FC00003FF00000C00003FC00003FF00000C00003FE000
+03FF00000C00001FE00007FF80001800001FE000067F80001800001FE000067F80001800
+000FF0000E7FC0003000000FF0000C3FC0003000000FF0000C3FC00030000007F8001C3F
+E00060000007F800181FE00060000007F800181FE00060000003FC00181FF000C0000003
+FC00300FF000C0000003FC00300FF000C0000001FE00300FF80180000001FE006007F801
+80000001FE006007F80180000000FF006007F80300000000FF00C003FC0300000000FF00
+C003FC0300000000FF80C003FC07000000007F818001FE06000000007F818001FE060000
+00007FC18001FE0E000000003FC30000FF0C000000003FC30000FF0C000000003FE30000
+FF1C000000001FE600007F98000000001FE600007F98000000001FF600007F9800000000
+0FFC00003FF0000000000FFC00003FF0000000000FFC00003FF00000000007FC00003FE0
+0000000007F800001FE00000000007F800001FE00000000003F800001FC00000000003F0
+00000FC00000000003F000000FC00000000001F000000F800000000001E0000007800000
+000001E0000007800000000000E0000007000000000000C0000003000000503B7EB855>
+I<0180038007000E001C00180038003000700060006000E000C000C000C000C000CE00FF
+80FFC0FFC0FFC07FC07FC03F800E000A197AB917>96 D<001FE0000000FFFC000003E03F
+000007000F80000F8007E0001FC003F0001FE003F0001FE001F8001FE001F8001FE000FC
+000FC000FC00078000FC00000000FC00000000FC00000000FC00000000FC0000007FFC00
+0007FFFC00003FE0FC0000FE00FC0003F800FC000FF000FC001FC000FC003FC000FC007F
+8000FC007F0000FC007F0000FC0CFE0000FC0CFE0000FC0CFE0000FC0CFE0001FC0CFE00
+01FC0CFF0003FC0C7F00077C0C7F80063E183FC01E3E180FE0781FF003FFF00FE0007F80
+07C026277DA52A>I<03F0000000FFF0000000FFF0000000FFF00000000FF000000003F0
+00000003F000000003F000000003F000000003F000000003F000000003F000000003F000
+000003F000000003F000000003F000000003F000000003F000000003F000000003F00000
+0003F000000003F01FE00003F07FF80003F1E03E0003F3801F8003F7000FC003FE0007E0
+03FC0003F003F80001F803F00001F803F00000FC03F00000FC03F00000FE03F00000FE03
+F000007E03F000007F03F000007F03F000007F03F000007F03F000007F03F000007F03F0
+00007F03F000007F03F000007F03F000007F03F000007E03F00000FE03F00000FE03F000
+00FC03F00001FC03F80001F803F80003F003FC0003F003EE0007E003C6000FC003C7801F
+000381E07E000300FFF80000001FC000283B7EB92E>I<0003FC00001FFF80007E03E001
+F8007003F000F807E001FC0FC003FC0FC003FC1F8003FC3F8003FC3F0001F87F0000F07F
+0000007F0000007E000000FE000000FE000000FE000000FE000000FE000000FE000000FE
+000000FE000000FE000000FE0000007E0000007F0000007F0000003F0000063F8000061F
+80000E1FC0000C0FC0001C07E0003803F0007001F800E0007C07C0001FFF000007F8001F
+277DA525>I<0000000FC0000003FFC0000003FFC0000003FFC00000003FC00000000FC0
+0000000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC000
+00000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000
+000FC00003F80FC0001FFF0FC0007E078FC000F801EFC003F0007FC007E0003FC00FC000
+1FC00FC0001FC01F80000FC03F80000FC03F00000FC07F00000FC07F00000FC07E00000F
+C0FE00000FC0FE00000FC0FE00000FC0FE00000FC0FE00000FC0FE00000FC0FE00000FC0
+FE00000FC0FE00000FC0FE00000FC07E00000FC07F00000FC07F00000FC03F00000FC03F
+00000FC01F80001FC01F80001FC00FC0003FC007E0007FC003F000EFF001F801CFFF007C
+078FFF001FFE0FFF0007F80FC0283B7DB92E>I<0007F800001FFF00007C0FC001F803E0
+03F001F007E001F80FC000F81F80007C1F80007C3F00007E3F00003E7F00003E7F00003F
+7E00003FFE00003FFE00003FFE00003FFFFFFFFFFFFFFFFFFE000000FE000000FE000000
+FE000000FE0000007E0000007E0000007F0000007F0000003F0000033F8000031F800007
+0FC0000607C0000E07E0001C01F0003800F80070007E03E0001FFF800003FC0020277EA5
+25>I<00007E000003FF80000FC1E0001F87E0003F0FF0007E0FF0007E0FF000FC0FF000
+FC0FF001F803C001F8000001F8000001F8000001F8000001F8000001F8000001F8000001
+F8000001F8000001F8000001F8000001F8000001F80000FFFFFC00FFFFFC00FFFFFC0001
+F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001
+F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001
+F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001
+F8000001F8000003FC00007FFFF8007FFFF8007FFFF8001C3B7FBA19>I<00000003F000
+0FF00FF8003FFC3C3C00F81F707C01F00FE07C03E007C07C07C003E0100FC003F0000FC0
+03F0001F8001F8001F8001F8001F8001F8001F8001F8001F8001F8001F8001F8001F8001
+F8001F8001F8000FC003F0000FC003F00007C003E00003E007C00003F00F800003F81F00
+00073FFC0000060FF000000E000000000E000000000E000000000E000000000F00000000
+0F000000000FC000000007FFFFC00007FFFFF80003FFFFFE0001FFFFFF8003FFFFFFC00F
+80007FE01F00000FF03E000003F07C000001F07C000001F8F8000000F8F8000000F8F800
+0000F8F8000000F8F8000000F8FC000001F87C000001F03E000003E03F000007E00F8000
+0F8007E0003F0001FC01FC00007FFFF0000007FF000026387EA52A>I<03F000000000FF
+F000000000FFF000000000FFF0000000000FF00000000003F00000000003F00000000003
+F00000000003F00000000003F00000000003F00000000003F00000000003F00000000003
+F00000000003F00000000003F00000000003F00000000003F00000000003F00000000003
+F00000000003F00000000003F00FF0000003F03FFC000003F0F03F000003F1C01F800003
+F3800FC00003F7000FC00003FE000FC00003FC0007E00003FC0007E00003F80007E00003
+F80007E00003F80007E00003F00007E00003F00007E00003F00007E00003F00007E00003
+F00007E00003F00007E00003F00007E00003F00007E00003F00007E00003F00007E00003
+F00007E00003F00007E00003F00007E00003F00007E00003F00007E00003F00007E00003
+F00007E00003F00007E00003F00007E00003F00007E00003F00007E00007F8000FF000FF
+FFC1FFFF80FFFFC1FFFF80FFFFC1FFFF80293A7EB92E>I<0380000FE0001FF0001FF000
+1FF0001FF0001FF0000FE000038000000000000000000000000000000000000000000000
+00000000000000000003F000FFF000FFF000FFF00007F00003F00003F00003F00003F000
+03F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F000
+03F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F000
+07F800FFFFC0FFFFC0FFFFC012387EB717>I<0001C00007F0000FF8000FF8000FF8000F
+F8000FF80007F00001C00000000000000000000000000000000000000000000000000000
+000000000001F800FFF800FFF800FFF80007F80001F80001F80001F80001F80001F80001
+F80001F80001F80001F80001F80001F80001F80001F80001F80001F80001F80001F80001
+F80001F80001F80001F80001F80001F80001F80001F80001F80001F80001F80001F80001
+F80001F80001F80001F80001F80001F80001F80001F80001F83C01F87E01F8FF01F0FF03
+F0FF03F0FF03E0FE07C07C07C03C0F000FFE0003F800154984B719>I<03F0000000FFF0
+000000FFF0000000FFF00000000FF000000003F000000003F000000003F000000003F000
+000003F000000003F000000003F000000003F000000003F000000003F000000003F00000
+0003F000000003F000000003F000000003F000000003F000000003F000000003F001FFFC
+03F001FFFC03F001FFFC03F0007FC003F0007F0003F0007C0003F000700003F000E00003
+F001C00003F003800003F007000003F01E000003F038000003F078000003F0FC000003F1
+FC000003F3FE000003F73F000003FE3F800003F81F800003F00FC00003F00FE00003F007
+E00003F003F00003F001F80003F001FC0003F000FC0003F0007E0003F0007F0003F0003F
+0003F0003F8003F0001FC007F8003FF0FFFFC0FFFFFFFFC0FFFFFFFFC0FFFF283A7EB92C
+>I<03F000FFF000FFF000FFF0000FF00003F00003F00003F00003F00003F00003F00003
+F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003
+F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003
+F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003
+F00003F00003F00003F00003F00003F00003F00007F800FFFFC0FFFFC0FFFFC0123A7EB9
+17>I<03F00FF0001FE000FFF03FFC007FF800FFF0F03F01E07E00FFF1C01F83803F000F
+F3800FC7001F8003F7000FCE001F8003FE000FDC001F8003FC0007F8000FC003FC0007F8
+000FC003F80007F0000FC003F80007F0000FC003F80007F0000FC003F00007E0000FC003
+F00007E0000FC003F00007E0000FC003F00007E0000FC003F00007E0000FC003F00007E0
+000FC003F00007E0000FC003F00007E0000FC003F00007E0000FC003F00007E0000FC003
+F00007E0000FC003F00007E0000FC003F00007E0000FC003F00007E0000FC003F00007E0
+000FC003F00007E0000FC003F00007E0000FC003F00007E0000FC003F00007E0000FC003
+F00007E0000FC003F00007E0000FC007F8000FF0001FE0FFFFC1FFFF83FFFFFFFFC1FFFF
+83FFFFFFFFC1FFFF83FFFF40257EA445>I<03F00FF00000FFF03FFC0000FFF0F03F0000
+FFF1C01F80000FF3800FC00003F7000FC00003FE000FC00003FC0007E00003FC0007E000
+03F80007E00003F80007E00003F80007E00003F00007E00003F00007E00003F00007E000
+03F00007E00003F00007E00003F00007E00003F00007E00003F00007E00003F00007E000
+03F00007E00003F00007E00003F00007E00003F00007E00003F00007E00003F00007E000
+03F00007E00003F00007E00003F00007E00003F00007E00003F00007E00003F00007E000
+07F8000FF000FFFFC1FFFF80FFFFC1FFFF80FFFFC1FFFF8029257EA42E>I<0003FE0000
+000FFF8000003E03E00000F800F80001F0007C0003E0003E0007C0001F000F80000F801F
+80000FC01F000007C03F000007E03F000007E07E000003F07E000003F07E000003F07E00
+0003F0FE000003F8FE000003F8FE000003F8FE000003F8FE000003F8FE000003F8FE0000
+03F8FE000003F8FE000003F87E000003F07E000003F07F000007F03F000007E03F000007
+E01F80000FC00F80000F800FC0001F8007E0003F0003F0007E0000F800F800007E03F000
+001FFFC0000003FE000025277EA52A>I<03F01FE000FFF07FF800FFF1E07E00FFF3801F
+8007F7000FC003FE0007E003FC0003F003F80003F803F00001F803F00001FC03F00000FC
+03F00000FE03F00000FE03F00000FE03F000007F03F000007F03F000007F03F000007F03
+F000007F03F000007F03F000007F03F000007F03F000007F03F000007F03F00000FE03F0
+0000FE03F00000FE03F00001FC03F00001FC03F80003F803F80003F003FC0007F003FE00
+0FE003F6000FC003F7803F0003F1E07E0003F0FFF80003F01FC00003F000000003F00000
+0003F000000003F000000003F000000003F000000003F000000003F000000003F0000000
+03F000000003F000000007F8000000FFFFC00000FFFFC00000FFFFC0000028357EA42E>
+I<0003F800C0001FFE01C0007E0781C000FC01C3C003F000E3C007F00077C00FE00037C0
+0FC0003FC01FC0001FC03F80001FC03F80000FC07F00000FC07F00000FC07F00000FC0FE
+00000FC0FE00000FC0FE00000FC0FE00000FC0FE00000FC0FE00000FC0FE00000FC0FE00
+000FC0FE00000FC0FE00000FC07F00000FC07F00000FC07F00000FC03F00000FC03F8000
+1FC01F80001FC01FC0003FC00FC0003FC007E0007FC003F000EFC001F801CFC0007E078F
+C0001FFE0FC00007F80FC00000000FC00000000FC00000000FC00000000FC00000000FC0
+0000000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000001FE000
+0003FFFF000003FFFF000003FFFF28357DA42C>I<07E01F00FFE07FC0FFE1E3E0FFE387
+F00FE707F003E607F003EE07F003EC03E003FC008003F8000003F8000003F8000003F800
+0003F0000003F0000003F0000003F0000003F0000003F0000003F0000003F0000003F000
+0003F0000003F0000003F0000003F0000003F0000003F0000003F0000003F0000003F000
+0003F0000003F0000007F80000FFFFF000FFFFF000FFFFF0001C257EA421>I<00FF0300
+03FFE7000F80FF001E003F003C001F0078000F0070000700F0000700F0000700F0000300
+F8000300F8000300FC000300FF0000007FE000007FFF00003FFFE0001FFFF8000FFFFC00
+03FFFE0000FFFF000007FF8000007F8000001F80C0000FC0C00007C0C00007C0E00003C0
+E00003C0E00003C0F00003C0F0000380F8000780FC000780FC000F00FF001E00F3C07C00
+E1FFF000C03F80001A277DA521>I<001800000018000000180000001800000018000000
+380000003800000038000000780000007800000078000000F8000001F8000003F8000007
+F800001FFFFF00FFFFFF00FFFFFF0001F8000001F8000001F8000001F8000001F8000001
+F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001
+F8000001F8000001F8000001F8000001F800C001F800C001F800C001F800C001F800C001
+F800C001F800C001F800C001F800C000FC01C000FC0180007C0380007E0300003F070000
+0FFE000001F8001A347FB220>I<03F00007E000FFF001FFE000FFF001FFE000FFF001FF
+E0000FF0001FE00003F00007E00003F00007E00003F00007E00003F00007E00003F00007
+E00003F00007E00003F00007E00003F00007E00003F00007E00003F00007E00003F00007
+E00003F00007E00003F00007E00003F00007E00003F00007E00003F00007E00003F00007
+E00003F00007E00003F00007E00003F00007E00003F00007E00003F00007E00003F0000F
+E00003F0000FE00003F0000FE00003F0001FE00001F0001FE00001F8003FE00000F80077
+F80000FC00E7FF80003F03C7FF80001FFF87FF800003FC07E00029267EA42E>I<FFFF80
+3FFEFFFF803FFEFFFF803FFE0FF8000FF007F00007E003F00003C003F800038001F80003
+0001F800030000FC00060000FC00060000FE000E00007E000C00007E000C00003F001800
+003F001800003F803800001F803000001F803000000FC06000000FC06000000FE0600000
+07E0C0000007E0C0000003F180000003F180000003F180000001FB00000001FB00000001
+FF00000000FE00000000FE000000007C000000007C000000007C00000000380000000038
+000027257EA32C>I<FFFF1FFFE03FFEFFFF1FFFE03FFEFFFF1FFFE03FFE0FF800FF000F
+F807F0007E0003E007F0007E0003C003F0003E00018003F0003E00018001F8003F000300
+01F8003F00030001F8003F00030000FC003F80060000FC006F80060000FC006F80060000
+7E00EFC00C00007E00C7C00C00007E00C7C00C00003F01C7E01800003F0183E01800003F
+8183F03800001F8383F03000001F8301F03000001FC301F87000000FC600F86000000FC6
+00F860000007E600FCC0000007EC007CC0000007EC007CC0000003FC007F80000003F800
+3F80000003F8003F80000001F8003F00000001F0001F00000001F0001F00000000F0001E
+00000000E0000E0000000060000C000037257EA33C>I<FFFF807FFF00FFFF807FFF00FF
+FF807FFF0003FE003FF00001FE001F800000FE001F0000007E001C0000003F0018000000
+1F80300000001FC0700000000FC0E000000007E0C000000007F18000000003FB80000000
+01FF0000000000FE0000000000FE00000000007F00000000003F00000000007F80000000
+007FC000000000CFC000000001C7E00000000383F00000000703F80000000601F8000000
+0C00FC0000001C007E00000038007F00000078003F000000F0001F800001F8001FC0000F
+F8003FF000FFFE00FFFF80FFFE00FFFF80FFFE00FFFF8029247FA32C>I<FFFF803FFEFF
+FF803FFEFFFF803FFE0FF8000FF007F00007C003F000038001F800038001F800030001FC
+00030000FC00060000FC000600007E000C00007E000C00007F000C00003F001800003F00
+1800001F803000001F803000001FC07000000FC06000000FC060000007E0C0000007E0C0
+000007F1C0000003F180000003F180000001FB00000001FB00000001FF00000000FE0000
+0000FE000000007C000000007C000000007C000000003800000000380000000030000000
+003000000000700000000060000000006000000000C000000000C000007C01C00000FE01
+800000FE03800000FE03000000FE06000000FC0E000000701C00000038380000001FF000
+00000FC000000027357EA32C>I<3FFFFFFC3FFFFFFC3F8003FC3E0003F83C0007F03800
+0FE030000FE070001FC070003F8060007F8060007F006000FE006001FC006001FC000003
+F8000007F0000007F000000FE000001FC000003F8000003F8000007F000600FE000600FE
+000601FC000603F8000607F8000E07F0000E0FE0000C1FC0001C1FC0001C3F80003C7F00
+007CFF0003FCFFFFFFFCFFFFFFFC1F247EA325>I E /Fk 42 122
+df<000003FFC0000000003FFFFC00000000FFFFFF00000003FFFFFFC000000FFF81FFF0
+00001FFC003FF800003FF8001FFC00007FF0000FFE0000FFE00007FF0001FFC00003FF80
+03FF800001FFC003FF800001FFC007FF800001FFE00FFF000000FFF00FFF000000FFF00F
+FF000000FFF01FFF000000FFF81FFF000000FFF83FFF000000FFFC3FFE0000007FFC3FFE
+0000007FFC3FFE0000007FFC7FFE0000007FFE7FFE0000007FFE7FFE0000007FFE7FFE00
+00007FFE7FFE0000007FFE7FFE0000007FFEFFFE0000007FFFFFFE0000007FFFFFFE0000
+007FFFFFFE0000007FFFFFFE0000007FFFFFFE0000007FFFFFFE0000007FFFFFFE000000
+7FFFFFFE0000007FFFFFFE0000007FFFFFFE0000007FFFFFFE0000007FFFFFFE0000007F
+FFFFFE0000007FFFFFFE0000007FFFFFFE0000007FFFFFFE0000007FFFFFFE0000007FFF
+FFFE0000007FFFFFFE0000007FFFFFFE0000007FFFFFFE0000007FFFFFFE0000007FFF7F
+FE0000007FFE7FFE0000007FFE7FFE0000007FFE7FFE0000007FFE7FFE0000007FFE7FFE
+0000007FFE3FFE0000007FFC3FFE0000007FFC3FFF000000FFFC3FFF000000FFFC1FFF00
+0000FFF81FFF000000FFF81FFF000000FFF80FFF000000FFF00FFF000000FFF007FF8000
+01FFE007FF800001FFE003FFC00003FFC001FFC00003FF8001FFE00007FF8000FFF0000F
+FF00007FF8001FFE00001FFC003FF800000FFF81FFF0000007FFFFFFE0000001FFFFFF80
+0000003FFFFC0000000003FFC00000384F7BCD43>48 D<000000780000000000FC000000
+0003FC0000000007FC000000001FFC00000000FFFC0000000FFFFC000007FFFFFC0000FF
+FFFFFC0000FFFFFFFC0000FFFF7FFC0000FFF07FFC0000F8007FFC000000007FFC000000
+007FFC000000007FFC000000007FFC000000007FFC000000007FFC000000007FFC000000
+007FFC000000007FFC000000007FFC000000007FFC000000007FFC000000007FFC000000
+007FFC000000007FFC000000007FFC000000007FFC000000007FFC000000007FFC000000
+007FFC000000007FFC000000007FFC000000007FFC000000007FFC000000007FFC000000
+007FFC000000007FFC000000007FFC000000007FFC000000007FFC000000007FFC000000
+007FFC000000007FFC000000007FFC000000007FFC000000007FFC000000007FFC000000
+007FFC000000007FFC000000007FFC000000007FFC000000007FFC000000007FFC000000
+007FFC000000007FFC000000007FFC000000007FFC000000007FFC000000007FFC000000
+007FFC000000007FFC000000007FFC000000007FFC000000007FFC000000007FFC000000
+007FFC000000007FFC000000007FFC000000007FFC000000007FFC00007FFFFFFFFFFE7F
+FFFFFFFFFE7FFFFFFFFFFE7FFFFFFFFFFE7FFFFFFFFFFE2F4E76CD43>I<00003FFE0000
+000003FFFFE00000000FFFFFFC0000003FFFFFFF000000FFFFFFFFC00001FFC07FFFE000
+03FE000FFFF80007F80003FFFC000FE00001FFFE001FC00000FFFF003F8000007FFF003F
+F000007FFF807FF800003FFFC07FFC00003FFFC0FFFE00001FFFE0FFFF00001FFFE0FFFF
+00001FFFE0FFFF00000FFFF0FFFF00000FFFF0FFFF00000FFFF0FFFF00000FFFF0FFFF00
+000FFFF07FFE00000FFFF07FFE00000FFFF03FFC00000FFFF00FF000000FFFF003C00000
+0FFFF0000000000FFFE0000000001FFFE0000000001FFFE0000000001FFFC0000000003F
+FFC0000000003FFF80000000003FFF80000000007FFF00000000007FFE0000000000FFFC
+0000000001FFF80000000001FFF00000000003FFE00000000003FFC00000000007FF8000
+0000000FFF00000000001FFE00000000001FFC00000000003FF800000000007FE0000000
+0000FFC00000000001FF800000000003FE000000000007FC000000000007F80000000000
+0FF00001F000001FE00001F000003F800001F000007F000001F00000FE000003E00001FC
+000003E00003F8000003E00007F0000003E0000FE0000003E0001F80000007E0003F0000
+0007E0003E0000000FE0007FFFFFFFFFE000FFFFFFFFFFC001FFFFFFFFFFC003FFFFFFFF
+FFC007FFFFFFFFFFC00FFFFFFFFFFFC01FFFFFFFFFFFC03FFFFFFFFFFFC07FFFFFFFFFFF
+C0FFFFFFFFFFFFC0FFFFFFFFFFFF80FFFFFFFFFFFF80FFFFFFFFFFFF80FFFFFFFFFFFF80
+344E79CD43>I<00000FFFC000000000FFFFFC00000007FFFFFF8000001FFFFFFFE00000
+3FF807FFF00000FF8001FFFC0001FE00007FFE0003F800003FFF0003F000003FFF8007FC
+00001FFF800FFF00001FFFC00FFF80001FFFC01FFFC0001FFFE01FFFC0001FFFE01FFFC0
+001FFFE01FFFC0001FFFE01FFFE0001FFFE01FFFC0001FFFE01FFFC0001FFFE01FFFC000
+1FFFE00FFFC0001FFFC007FF80001FFFC003FF00003FFFC001FC00003FFF80000000003F
+FF80000000007FFF00000000007FFE00000000007FFE0000000000FFFC0000000001FFF8
+0000000003FFF00000000007FFC0000000000FFF8000000000FFFE00000000FFFFF80000
+0000FFFFE000000000FFFFFC00000000FFFFFF800000000007FFE00000000001FFF80000
+0000007FFE00000000003FFF00000000001FFF80000000000FFFC0000000000FFFE00000
+000007FFF00000000007FFF00000000007FFF80000000007FFF80000000003FFFC000000
+0003FFFC0000000003FFFE0000000003FFFE03E0000003FFFE0FF8000003FFFE1FFC0000
+03FFFE3FFE000003FFFE7FFF000003FFFEFFFF800003FFFEFFFF800003FFFEFFFF800003
+FFFEFFFF800003FFFCFFFF800003FFFCFFFF800007FFFCFFFF800007FFF8FFFF000007FF
+F87FFF000007FFF07FFE00000FFFF03FFC00000FFFE03FF000001FFFC01FE000003FFF80
+0FF800007FFF0007FF0000FFFE0003FFF007FFFC0000FFFFFFFFF000007FFFFFFFE00000
+1FFFFFFF80000003FFFFFC000000001FFF800000374F7ACD43>I<00000000007C000000
+00000000FE00000000000000FE00000000000001FE00000000000003FE00000000000007
+FE0000000000000FFE0000000000000FFE0000000000001FFE0000000000003FFE000000
+0000007FFE0000000000007FFE000000000000FFFE000000000001FFFE000000000003FF
+FE000000000003FFFE000000000007FFFE00000000000FFFFE00000000001FBFFE000000
+00003F3FFE00000000003E3FFE00000000007C3FFE0000000000FC3FFE0000000001F83F
+FE0000000001F03FFE0000000003E03FFE0000000007E03FFE000000000FC03FFE000000
+000F803FFE000000001F003FFE000000003F003FFE000000007E003FFE000000007C003F
+FE00000000F8003FFE00000001F8003FFE00000003F0003FFE00000007E0003FFE000000
+07C0003FFE0000000F80003FFE0000001F80003FFE0000003F00003FFE0000003E00003F
+FE0000007C00003FFE000000FC00003FFE000001F800003FFE000001F000003FFE000003
+E000003FFE000007E000003FFE00000FC000003FFE00001F8000003FFE00001F0000003F
+FE00003E0000003FFE00007E0000003FFE0000FC0000003FFE0000FFFFFFFFFFFFFFC0FF
+FFFFFFFFFFFFC0FFFFFFFFFFFFFFC0FFFFFFFFFFFFFFC0FFFFFFFFFFFFFFC0000000007F
+FE0000000000007FFE0000000000007FFE0000000000007FFE0000000000007FFE000000
+0000007FFE0000000000007FFE0000000000007FFE0000000000007FFE0000000000007F
+FE0000000000007FFE0000000000007FFE0000000000007FFE0000000000007FFE000000
+0000007FFE000000000FFFFFFFFFC000000FFFFFFFFFC000000FFFFFFFFFC000000FFFFF
+FFFFC000000FFFFFFFFFC03A4F7CCE43>I<03800000000E0007E00000007E0007FE0000
+03FE0007FFF0007FFE0007FFFFFFFFFC0007FFFFFFFFF80007FFFFFFFFF00007FFFFFFFF
+E00007FFFFFFFFC00007FFFFFFFF800007FFFFFFFF000007FFFFFFFE000007FFFFFFFC00
+0007FFFFFFF0000007FFFFFFC0000007FFFFFF00000007FFFFF800000007E1FF00000000
+07E0000000000007E0000000000007E0000000000007E0000000000007E0000000000007
+E0000000000007E0000000000007E0000000000007E0000000000007E0000000000007E0
+000000000007E00FFF00000007E07FFFF0000007E3FFFFFE000007E7FFFFFF800007FFF8
+07FFC00007FFC001FFE00007FE0000FFF80007FC00007FFC0007F800003FFC0007F00000
+3FFE0007E000001FFF0003C000001FFF80000000001FFF80000000001FFFC0000000000F
+FFC0000000000FFFE0000000000FFFE0000000000FFFE0000000000FFFE0000000000FFF
+F0000000000FFFF0000000000FFFF00FE000000FFFF01FF000000FFFF03FF800000FFFF0
+7FFC00000FFFF0FFFE00000FFFF0FFFE00000FFFF0FFFE00000FFFF0FFFE00000FFFF0FF
+FE00000FFFE0FFFE00000FFFE0FFFE00000FFFE0FFFC00000FFFE07FF800001FFFC07FF0
+00001FFFC07FE000001FFF803E0000003FFF803F0000003FFF001F8000007FFE001FC000
+007FFC000FE00000FFF80007F80001FFF00003FE0007FFE00001FFC03FFFC00000FFFFFF
+FF8000003FFFFFFE0000001FFFFFF800000003FFFFC0000000007FF8000000344F79CD43
+>I<0000000FFF0000000000FFFFE000000007FFFFF00000001FFFFFFC0000007FFE03FE
+000001FFF0007F000003FFC0003F800007FF00001F80000FFE00007FC0001FFC0000FFC0
+003FF80001FFE0007FF00003FFE000FFF00007FFE001FFE00007FFE001FFE00007FFE003
+FFC00007FFE007FFC00007FFE007FFC00007FFE00FFFC00003FFC00FFF800001FF801FFF
+800000FF001FFF8000007E001FFF80000000003FFF80000000003FFF80000000003FFF00
+000000007FFF00000000007FFF00000000007FFF00080000007FFF01FFF800007FFF07FF
+FF0000FFFF0FFFFFC000FFFF1FFFFFF000FFFF3F007FF800FFFF3C003FFC00FFFF78001F
+FE00FFFFF0000FFF00FFFFF00007FF80FFFFE00007FFC0FFFFE00007FFC0FFFFC00007FF
+E0FFFFC00003FFF0FFFF800003FFF0FFFF800003FFF8FFFF800003FFF8FFFF800003FFF8
+FFFF800003FFF8FFFF000003FFFCFFFF000003FFFCFFFF000003FFFC7FFF000003FFFC7F
+FF000003FFFC7FFF000003FFFC7FFF000003FFFC7FFF000003FFFC7FFF000003FFFC3FFF
+000003FFFC3FFF000003FFFC3FFF000003FFFC3FFF000003FFFC1FFF000003FFF81FFF80
+0003FFF81FFF800003FFF80FFF800003FFF80FFF800003FFF007FF800007FFF007FF8000
+07FFE003FFC00007FFC001FFC00007FFC001FFE0000FFF8000FFF0000FFF00007FF8001F
+FE00003FFC007FFC00001FFF01FFF800000FFFFFFFF0000003FFFFFFC0000000FFFFFF00
+0000003FFFFC0000000007FFC00000364F7ACD43>I<1F000000000000001F8000000000
+00001FC00000000000001FFF8000000000001FFFFFFFFFFFFF801FFFFFFFFFFFFF801FFF
+FFFFFFFFFF801FFFFFFFFFFFFF803FFFFFFFFFFFFF803FFFFFFFFFFFFF003FFFFFFFFFFF
+FE003FFFFFFFFFFFFC003FFFFFFFFFFFF8003FFFFFFFFFFFF8003FFFFFFFFFFFF0003FFF
+FFFFFFFFE0003FFFFFFFFFFFC0007FFFFFFFFFFF80007F800000007F00007E00000000FF
+00007E00000001FE00007C00000003FC00007C00000003F800007C00000007F000007C00
+00000FF000007C0000001FE00000F80000003FC00000F80000007F800000F80000007F00
+0000F8000000FE00000000000001FE00000000000003FC00000000000003F80000000000
+0007F00000000000000FF00000000000001FE00000000000001FE00000000000003FC000
+00000000003FC00000000000007F80000000000000FF80000000000000FF800000000000
+01FF00000000000001FF00000000000003FF00000000000003FE00000000000007FE0000
+0000000007FE0000000000000FFE0000000000000FFE0000000000000FFC000000000000
+1FFC0000000000001FFC0000000000003FFC0000000000003FFC0000000000003FFC0000
+000000003FFC0000000000007FFC0000000000007FF80000000000007FF8000000000000
+7FF8000000000000FFF8000000000000FFF8000000000000FFF8000000000000FFF80000
+00000000FFF8000000000001FFF8000000000001FFF8000000000001FFF8000000000001
+FFF8000000000001FFF8000000000001FFF8000000000001FFF8000000000001FFF80000
+00000001FFF8000000000001FFF8000000000001FFF8000000000001FFF8000000000000
+FFF0000000000000FFF00000000000003FC00000000000001F8000000000395279D043>
+I<000007FFC0000000007FFFFC00000003FFFFFF8000000FFFFFFFE000001FFC01FFF800
+003FE0003FFC00007F80000FFE0000FF000007FF0001FE000003FF0003FC000001FF8007
+FC000001FFC007F8000000FFC00FF8000000FFC00FF8000000FFE00FF80000007FE00FF8
+0000007FE01FF80000007FE01FFC0000007FE01FFC0000007FE01FFE0000007FE01FFF00
+00007FE01FFF800000FFE01FFFE00000FFC01FFFF80000FFC01FFFFE0001FF800FFFFF00
+01FF800FFFFFC003FF000FFFFFF007FE0007FFFFF807FC0007FFFFFE1FF80003FFFFFFBF
+F00001FFFFFFFFE00001FFFFFFFF800000FFFFFFFE0000007FFFFFFF0000003FFFFFFF80
+00000FFFFFFFE0000007FFFFFFF0000001FFFFFFFC000007FFFFFFFE00001FFFFFFFFF00
+003FFFFFFFFF8000FFE7FFFFFF8001FF81FFFFFFC003FF007FFFFFE007FE001FFFFFF00F
+FC000FFFFFF01FF80003FFFFF01FF80000FFFFF83FF000007FFFF83FF000001FFFF87FE0
+000007FFFC7FE0000001FFFC7FE0000000FFFCFFC00000007FFCFFC00000003FFCFFC000
+00003FFCFFC00000001FFCFFC00000001FFCFFC00000000FFCFFC00000000FFCFFC00000
+000FF8FFC00000000FF8FFE00000000FF87FE00000000FF07FF00000001FF07FF0000000
+1FF03FF80000003FE01FF80000003FC01FFC0000007FC00FFE000000FF8007FF800003FF
+0003FFE0000FFE0001FFFC00FFFC00007FFFFFFFF000003FFFFFFFE000000FFFFFFF8000
+0001FFFFFC000000000FFFC00000364F7ACD43>I<00000FFF8000000000FFFFF8000000
+03FFFFFE0000000FFFFFFF8000001FFF03FFC000007FF800FFE00000FFF0003FF00001FF
+E0001FF80003FFC0001FFC0007FFC0000FFE000FFF80000FFF000FFF800007FF001FFF80
+0007FF803FFF800007FF803FFF000007FFC07FFF000007FFC07FFF000003FFE07FFF0000
+03FFE07FFF000003FFF0FFFF000003FFF0FFFF000003FFF0FFFF000003FFF0FFFF000003
+FFF8FFFF000003FFF8FFFF000003FFF8FFFF000003FFF8FFFF000003FFF8FFFF000003FF
+F8FFFF000003FFFCFFFF000003FFFCFFFF000003FFFCFFFF000003FFFC7FFF000007FFFC
+7FFF000007FFFC7FFF000007FFFC3FFF000007FFFC3FFF000007FFFC3FFF00000FFFFC1F
+FF80000FFFFC0FFF80001FFFFC0FFF80001FFFFC07FF80003FFFFC03FFC0003FFFFC01FF
+E0007BFFFC00FFF000F3FFFC007FF803F3FFFC001FFFFFE3FFFC000FFFFFC3FFFC0003FF
+FF83FFF800007FFE03FFF80000004003FFF80000000003FFF80000000003FFF800000000
+03FFF00000000007FFF00000000007FFF00000000007FFF001F8000007FFE003FC000007
+FFE007FE000007FFC00FFF000007FFC01FFF80000FFF801FFF80000FFF801FFF80000FFF
+001FFF80001FFF001FFF80001FFE001FFF80003FFC001FFF00003FFC000FFE00007FF800
+0FFC0000FFF0000FF80001FFE00007F00003FFC00003FC000FFF800003FF807FFE000001
+FFFFFFFC0000007FFFFFF00000003FFFFFC00000000FFFFE0000000000FFF0000000364F
+7ACD43>I<00000000001F00000000000000000000003F80000000000000000000007FC0
+000000000000000000007FC000000000000000000000FFE000000000000000000000FFE0
+00000000000000000000FFE000000000000000000001FFF000000000000000000001FFF0
+00000000000000000003FFF800000000000000000003FFF800000000000000000003FFF8
+00000000000000000007FFFC00000000000000000007FFFC00000000000000000007FFFC
+0000000000000000000FFFFE0000000000000000000FFFFE0000000000000000001FFFFF
+0000000000000000001FFFFF0000000000000000001FFFFF0000000000000000003FFFFF
+8000000000000000003F7FFF8000000000000000007F7FFFC000000000000000007E7FFF
+C000000000000000007E3FFFC00000000000000000FE3FFFE00000000000000000FC1FFF
+E00000000000000001FC1FFFF00000000000000001F81FFFF00000000000000001F80FFF
+F00000000000000003F80FFFF80000000000000003F007FFF80000000000000007F007FF
+FC0000000000000007E007FFFC0000000000000007E003FFFC000000000000000FE003FF
+FE000000000000000FC001FFFE000000000000001FC001FFFF000000000000001F8001FF
+FF000000000000001F8000FFFF000000000000003F8000FFFF800000000000003F00007F
+FF800000000000007F00007FFFC00000000000007E00007FFFC00000000000007E00003F
+FFC0000000000000FE00003FFFE0000000000000FC00001FFFE0000000000001FC00001F
+FFF0000000000001F800001FFFF0000000000001F800000FFFF0000000000003F800000F
+FFF8000000000003F0000007FFF8000000000007F0000007FFFC000000000007E0000007
+FFFC000000000007E0000003FFFC00000000000FFFFFFFFFFFFE00000000000FFFFFFFFF
+FFFE00000000001FFFFFFFFFFFFF00000000001FFFFFFFFFFFFF00000000001FFFFFFFFF
+FFFF00000000003F80000000FFFF80000000003F000000007FFF80000000007F00000000
+7FFFC0000000007F000000007FFFC0000000007E000000003FFFC000000000FE00000000
+3FFFE000000000FC000000001FFFE000000001FC000000001FFFF000000001FC00000000
+1FFFF000000001F8000000000FFFF000000003F8000000000FFFF800000003F000000000
+07FFF800000007F00000000007FFFC00000007F00000000007FFFC00000007E000000000
+03FFFC0000000FE00000000003FFFE0000000FC00000000003FFFE0000001FC000000000
+01FFFF000000FFFC0000000001FFFF0000FFFFFFF800000FFFFFFFFFE0FFFFFFF800000F
+FFFFFFFFE0FFFFFFF800000FFFFFFFFFE0FFFFFFF800000FFFFFFFFFE0FFFFFFF800000F
+FFFFFFFFE05B547BD366>65 D<0000000001FFFC000001C0000000007FFFFFC00003C000
+000007FFFFFFF80007C00000003FFFFFFFFE001FC0000000FFFFFFFFFF803FC0000003FF
+FFE003FFC07FC000000FFFFC00003FF0FFC000003FFFE000000FF9FFC000007FFF800000
+03FFFFC00001FFFE00000000FFFFC00003FFF8000000007FFFC00007FFF0000000003FFF
+C0000FFFE0000000001FFFC0001FFFC0000000000FFFC0003FFF800000000007FFC0007F
+FF000000000003FFC000FFFE000000000001FFC000FFFE000000000001FFC001FFFC0000
+00000000FFC003FFF8000000000000FFC003FFF80000000000007FC007FFF00000000000
+007FC00FFFF00000000000003FC00FFFF00000000000003FC01FFFE00000000000001FC0
+1FFFE00000000000001FC01FFFE00000000000001FC03FFFC00000000000001FC03FFFC0
+0000000000000FC03FFFC00000000000000FC07FFFC00000000000000FC07FFFC0000000
+0000000FC07FFFC000000000000000007FFF8000000000000000007FFF80000000000000
+0000FFFF800000000000000000FFFF800000000000000000FFFF800000000000000000FF
+FF800000000000000000FFFF800000000000000000FFFF800000000000000000FFFF8000
+00000000000000FFFF800000000000000000FFFF800000000000000000FFFF8000000000
+00000000FFFF800000000000000000FFFF800000000000000000FFFF8000000000000000
+00FFFF8000000000000000007FFF8000000000000000007FFF8000000000000000007FFF
+C000000000000000007FFFC000000000000000007FFFC000000000000007C03FFFC00000
+0000000007C03FFFC000000000000007C03FFFC000000000000007C01FFFE00000000000
+0007C01FFFE000000000000007C01FFFE00000000000000FC00FFFF00000000000000F80
+0FFFF00000000000000F8007FFF00000000000001F8003FFF80000000000001F8003FFF8
+0000000000001F0001FFFC0000000000003F0000FFFE0000000000007E0000FFFE000000
+0000007E00007FFF000000000000FC00003FFF800000000001F800001FFFC00000000003
+F800000FFFE00000000007F0000007FFF0000000000FE0000003FFFC000000001FC00000
+01FFFE000000007F800000007FFF80000000FF000000003FFFE0000007FE000000000FFF
+FE00001FF80000000003FFFFE001FFF00000000000FFFFFFFFFFC000000000003FFFFFFF
+FF00000000000007FFFFFFFC000000000000007FFFFFE00000000000000001FFFC000000
+00525479D261>67 D<FFFFFFFFFFFFFF8000000000FFFFFFFFFFFFFFFC00000000FFFFFF
+FFFFFFFFFF80000000FFFFFFFFFFFFFFFFF0000000FFFFFFFFFFFFFFFFFC0000000007FF
+F000000FFFFF0000000007FFF0000000FFFFC000000007FFF00000001FFFE000000007FF
+F000000007FFF800000007FFF000000001FFFC00000007FFF000000000FFFE00000007FF
+F0000000007FFF00000007FFF0000000003FFF80000007FFF0000000001FFFC0000007FF
+F0000000000FFFC0000007FFF00000000007FFE0000007FFF00000000003FFF0000007FF
+F00000000003FFF8000007FFF00000000001FFF8000007FFF00000000001FFFC000007FF
+F00000000000FFFC000007FFF00000000000FFFE000007FFF00000000000FFFE000007FF
+F000000000007FFF000007FFF000000000007FFF000007FFF000000000007FFF000007FF
+F000000000007FFF800007FFF000000000003FFF800007FFF000000000003FFF800007FF
+F000000000003FFFC00007FFF000000000003FFFC00007FFF000000000003FFFC00007FF
+F000000000003FFFC00007FFF000000000003FFFC00007FFF000000000003FFFE00007FF
+F000000000003FFFE00007FFF000000000003FFFE00007FFF000000000001FFFE00007FF
+F000000000001FFFE00007FFF000000000001FFFE00007FFF000000000001FFFE00007FF
+F000000000001FFFE00007FFF000000000001FFFE00007FFF000000000001FFFE00007FF
+F000000000001FFFE00007FFF000000000001FFFE00007FFF000000000003FFFE00007FF
+F000000000003FFFE00007FFF000000000003FFFE00007FFF000000000003FFFC00007FF
+F000000000003FFFC00007FFF000000000003FFFC00007FFF000000000003FFFC00007FF
+F000000000003FFFC00007FFF000000000003FFF800007FFF000000000003FFF800007FF
+F000000000007FFF800007FFF000000000007FFF000007FFF000000000007FFF000007FF
+F000000000007FFF000007FFF00000000000FFFE000007FFF00000000000FFFE000007FF
+F00000000000FFFC000007FFF00000000001FFFC000007FFF00000000001FFF8000007FF
+F00000000003FFF0000007FFF00000000007FFF0000007FFF00000000007FFE0000007FF
+F0000000000FFFC0000007FFF0000000001FFF80000007FFF0000000003FFF00000007FF
+F000000000FFFE00000007FFF000000001FFFC00000007FFF000000007FFF800000007FF
+F00000001FFFF000000007FFF0000000FFFFC000000007FFF000000FFFFF000000FFFFFF
+FFFFFFFFFFFE000000FFFFFFFFFFFFFFFFF0000000FFFFFFFFFFFFFFFFC0000000FFFFFF
+FFFFFFFFFC00000000FFFFFFFFFFFFFF80000000005B527CD167>I<FFFFFFFFFFFFFFFF
+FE00FFFFFFFFFFFFFFFFFE00FFFFFFFFFFFFFFFFFE00FFFFFFFFFFFFFFFFFE00FFFFFFFF
+FFFFFFFFFE000007FFF8000007FFFF000007FFF80000007FFF000007FFF80000001FFF00
+0007FFF800000007FF000007FFF800000003FF000007FFF800000001FF000007FFF80000
+0000FF000007FFF8000000007F000007FFF8000000003F000007FFF8000000003F800007
+FFF8000000003F800007FFF8000000001F800007FFF8000000001F800007FFF800000000
+1F800007FFF8000000000F800007FFF8000000000F800007FFF8000000000F800007FFF8
+000000000F800007FFF8000000000FC00007FFF80000F80007C00007FFF80000F80007C0
+0007FFF80000F80007C00007FFF80000F80007C00007FFF80000F80000000007FFF80000
+F80000000007FFF80000F80000000007FFF80001F80000000007FFF80001F80000000007
+FFF80001F80000000007FFF80003F80000000007FFF80007F80000000007FFF8000FF800
+00000007FFF8007FF80000000007FFFFFFFFF80000000007FFFFFFFFF80000000007FFFF
+FFFFF80000000007FFFFFFFFF80000000007FFFFFFFFF80000000007FFF8007FF8000000
+0007FFF8000FF80000000007FFF80007F80000000007FFF80003F80000000007FFF80001
+F80000000007FFF80001F80000000007FFF80001F80000000007FFF80000F80000000007
+FFF80000F80000000007FFF80000F80000000007FFF80000F80000000007FFF80000F800
+00000007FFF80000F80000000007FFF80000F80000000007FFF80000000000000007FFF8
+0000000000000007FFF80000000000000007FFF80000000000000007FFF8000000000000
+0007FFF80000000000000007FFF80000000000000007FFF80000000000000007FFF80000
+000000000007FFF80000000000000007FFF80000000000000007FFF80000000000000007
+FFF80000000000000007FFF80000000000000007FFF80000000000000007FFF800000000
+00000007FFF80000000000000007FFF80000000000000007FFF8000000000000FFFFFFFF
+FFF800000000FFFFFFFFFFF800000000FFFFFFFFFFF800000000FFFFFFFFFFF800000000
+FFFFFFFFFFF8000000004A517CD055>70 D<FFFFFFFFFFC003FFFFFFFFFFFFFFFFFFFFC0
+03FFFFFFFFFFFFFFFFFFFFC003FFFFFFFFFFFFFFFFFFFFC003FFFFFFFFFFFFFFFFFFFFC0
+03FFFFFFFFFF0007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFFFFFFF
+FFFFFFFFE0000007FFFFFFFFFFFFFFFFE0000007FFFFFFFFFFFFFFFFE0000007FFFFFFFF
+FFFFFFFFE0000007FFFFFFFFFFFFFFFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE000FFFFFFFFFFC003FFFFFFFFFFFFFFFFFFFFC003FFFFFFFFFFFFFFFFFFFFC0
+03FFFFFFFFFFFFFFFFFFFFC003FFFFFFFFFFFFFFFFFFFFC003FFFFFFFFFF60527CD169>
+72 D<FFFFFFFFFFC0FFFFFFFFFFC0FFFFFFFFFFC0FFFFFFFFFFC0FFFFFFFFFFC00007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF800000007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF800000007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF800000007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF800000007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF800000007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF800000007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF800000007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF800000007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF800000007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF800000007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF800000007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF80000FFFFFF
+FFFFC0FFFFFFFFFFC0FFFFFFFFFFC0FFFFFFFFFFC0FFFFFFFFFFC02A527CD132>I<FFFF
+FFFFFFF8000000FFFFFFFFFFF8000000FFFFFFFFFFF8000000FFFFFFFFFFF8000000FFFF
+FFFFFFF80000000007FFF800000000000007FFF800000000000007FFF800000000000007
+FFF800000000000007FFF800000000000007FFF800000000000007FFF800000000000007
+FFF800000000000007FFF800000000000007FFF800000000000007FFF800000000000007
+FFF800000000000007FFF800000000000007FFF800000000000007FFF800000000000007
+FFF800000000000007FFF800000000000007FFF800000000000007FFF800000000000007
+FFF800000000000007FFF800000000000007FFF800000000000007FFF800000000000007
+FFF800000000000007FFF800000000000007FFF800000000000007FFF800000000000007
+FFF800000000000007FFF800000000000007FFF800000000000007FFF800000000000007
+FFF800000000000007FFF800000000000007FFF800000000000007FFF800000000000007
+FFF800000000000007FFF800000000000007FFF800000000000007FFF800000000000007
+FFF800000000000007FFF800000000000007FFF800000000000007FFF800000000000007
+FFF800000000000007FFF800000000000007FFF8000000007C0007FFF8000000007C0007
+FFF8000000007C0007FFF8000000007C0007FFF800000000FC0007FFF800000000F80007
+FFF800000000F80007FFF800000000F80007FFF800000000F80007FFF800000000F80007
+FFF800000001F80007FFF800000001F80007FFF800000001F80007FFF800000003F80007
+FFF800000003F80007FFF800000007F80007FFF800000007F00007FFF80000000FF00007
+FFF80000000FF00007FFF80000001FF00007FFF80000003FF00007FFF80000007FF00007
+FFF8000000FFF00007FFF8000003FFF00007FFF8000007FFF00007FFF800003FFFF00007
+FFF80001FFFFF0FFFFFFFFFFFFFFFFE0FFFFFFFFFFFFFFFFE0FFFFFFFFFFFFFFFFE0FFFF
+FFFFFFFFFFFFE0FFFFFFFFFFFFFFFFE046527CD151>76 D<FFFFFFFFFFFFF00000000000
+FFFFFFFFFFFFFF8000000000FFFFFFFFFFFFFFF800000000FFFFFFFFFFFFFFFF00000000
+FFFFFFFFFFFFFFFFC00000000007FFF00000FFFFF00000000007FFF000000FFFF8000000
+0007FFF0000001FFFE0000000007FFF0000000FFFF0000000007FFF00000007FFF800000
+0007FFF00000003FFFC000000007FFF00000001FFFC000000007FFF00000000FFFE00000
+0007FFF00000000FFFF000000007FFF00000000FFFF000000007FFF000000007FFF80000
+0007FFF000000007FFF800000007FFF000000007FFF800000007FFF000000007FFFC0000
+0007FFF000000007FFFC00000007FFF000000007FFFC00000007FFF000000007FFFC0000
+0007FFF000000007FFFC00000007FFF000000007FFFC00000007FFF000000007FFFC0000
+0007FFF000000007FFFC00000007FFF000000007FFF800000007FFF000000007FFF80000
+0007FFF00000000FFFF800000007FFF00000000FFFF000000007FFF00000000FFFE00000
+0007FFF00000000FFFE000000007FFF00000001FFFC000000007FFF00000003FFF800000
+0007FFF00000007FFF0000000007FFF0000000FFFE0000000007FFF0000003FFFC000000
+0007FFF000000FFFF00000000007FFF00000FFFFC00000000007FFFFFFFFFFFF00000000
+0007FFFFFFFFFFF8000000000007FFFFFFFFFFE0000000000007FFFFFFFFFFF800000000
+0007FFF00003FFFE000000000007FFF000007FFF800000000007FFF000003FFFC0000000
+0007FFF000001FFFE00000000007FFF000000FFFF00000000007FFF0000007FFF8000000
+0007FFF0000003FFFC0000000007FFF0000003FFFE0000000007FFF0000001FFFE000000
+0007FFF0000001FFFE0000000007FFF0000001FFFF0000000007FFF0000000FFFF000000
+0007FFF0000000FFFF0000000007FFF0000000FFFF0000000007FFF0000000FFFF000000
+0007FFF0000000FFFF0000000007FFF0000000FFFF0000000007FFF0000000FFFF000000
+0007FFF0000000FFFF8000000007FFF0000000FFFF8000000007FFF0000000FFFF800000
+0007FFF0000000FFFF8000000007FFF0000000FFFF8000000007FFF0000000FFFF800000
+0007FFF0000000FFFF8000000007FFF0000000FFFF80001C0007FFF0000000FFFFC0003E
+0007FFF0000000FFFFC0003E0007FFF0000000FFFFC0003E0007FFF00000007FFFC0003E
+0007FFF00000007FFFE0007E0007FFF00000003FFFE0007C0007FFF00000003FFFF000FC
+0007FFF00000001FFFF001FCFFFFFFFFFF80000FFFF803F8FFFFFFFFFF800003FFFE07F0
+FFFFFFFFFF800001FFFFFFE0FFFFFFFFFF8000007FFFFFC0FFFFFFFFFF8000000FFFFF00
+0000000000000000007FFC005F537CD164>82 D<00000FFF800007000000FFFFF8000F00
+0007FFFFFF001F00001FFFFFFFC03F00003FFFFFFFF07F0000FFFC00FFF8FF0001FFE000
+0FFDFF0003FF800001FFFF0007FE0000007FFF000FFC0000003FFF000FF80000000FFF00
+1FF800000007FF001FF000000003FF003FF000000003FF003FE000000001FF007FE00000
+0000FF007FE000000000FF007FE0000000007F00FFE0000000007F00FFE0000000003F00
+FFE0000000003F00FFF0000000003F00FFF0000000003F00FFF8000000001F00FFF80000
+00001F00FFFC000000001F00FFFE000000001F00FFFF000000000000FFFFC00000000000
+7FFFF000000000007FFFFF00000000007FFFFFF8000000003FFFFFFF800000003FFFFFFF
+FC0000001FFFFFFFFFC000001FFFFFFFFFF000000FFFFFFFFFFC000007FFFFFFFFFF0000
+03FFFFFFFFFFC00001FFFFFFFFFFE00000FFFFFFFFFFF000007FFFFFFFFFF800003FFFFF
+FFFFFC00000FFFFFFFFFFE000003FFFFFFFFFE000000FFFFFFFFFF0000001FFFFFFFFF80
+000000FFFFFFFF800000000FFFFFFFC0000000007FFFFFC00000000007FFFFE000000000
+00FFFFE000000000003FFFE000000000000FFFF0000000000007FFF0000000000003FFF0
+000000000003FFF0780000000001FFF0F80000000000FFF0F80000000000FFF0F8000000
+0000FFF0F800000000007FF0F800000000007FF0FC00000000007FF0FC00000000007FF0
+FC00000000007FE0FE00000000007FE0FE00000000007FE0FF0000000000FFC0FF000000
+0000FFC0FF8000000000FFC0FFC000000001FF80FFE000000001FF00FFF000000003FF00
+FFFC00000007FE00FFFF0000000FFC00FFFFC000001FF800FFFFF800007FF000FF1FFFC0
+03FFE000FE0FFFFFFFFFC000FC03FFFFFFFF0000F8007FFFFFFC0000F0000FFFFFF00000
+E000007FFF0000003C5479D24B>I<FFFFFFFFFFC00003FFFFFFFCFFFFFFFFFFC00003FF
+FFFFFCFFFFFFFFFFC00003FFFFFFFCFFFFFFFFFFC00003FFFFFFFCFFFFFFFFFFC00003FF
+FFFFFC0007FFF80000000000FFF0000007FFF800000000001F80000007FFF80000000000
+1F80000007FFF800000000001F80000007FFF800000000001F80000007FFF80000000000
+1F80000007FFF800000000001F80000007FFF800000000001F80000007FFF80000000000
+1F80000007FFF800000000001F80000007FFF800000000001F80000007FFF80000000000
+1F80000007FFF800000000001F80000007FFF800000000001F80000007FFF80000000000
+1F80000007FFF800000000001F80000007FFF800000000001F80000007FFF80000000000
+1F80000007FFF800000000001F80000007FFF800000000001F80000007FFF80000000000
+1F80000007FFF800000000001F80000007FFF800000000001F80000007FFF80000000000
+1F80000007FFF800000000001F80000007FFF800000000001F80000007FFF80000000000
+1F80000007FFF800000000001F80000007FFF800000000001F80000007FFF80000000000
+1F80000007FFF800000000001F80000007FFF800000000001F80000007FFF80000000000
+1F80000007FFF800000000001F80000007FFF800000000001F80000007FFF80000000000
+1F80000007FFF800000000001F80000007FFF800000000001F80000007FFF80000000000
+1F80000007FFF800000000001F80000007FFF800000000001F80000007FFF80000000000
+1F80000007FFF800000000001F80000007FFF800000000001F80000007FFF80000000000
+1F80000007FFF800000000001F80000007FFF800000000001F80000007FFF80000000000
+1F80000007FFF800000000001F80000007FFF800000000001F80000007FFF80000000000
+1F80000007FFF800000000001F80000007FFF800000000001F80000007FFF80000000000
+1F80000007FFF800000000003F80000007FFF800000000003F80000003FFF80000000000
+3F00000003FFFC00000000003F00000003FFFC00000000007F00000001FFFC0000000000
+7F00000001FFFC00000000007E00000000FFFE0000000000FE00000000FFFE0000000001
+FC000000007FFF0000000001FC000000007FFF0000000003F8000000003FFF8000000007
+F8000000001FFF800000000FF0000000000FFFC00000001FE00000000007FFE00000003F
+C00000000003FFF80000007F800000000001FFFC000003FF0000000000007FFF80000FFE
+0000000000003FFFF001FFF80000000000000FFFFFFFFFF000000000000003FFFFFFFFC0
+000000000000007FFFFFFF00000000000000000FFFFFF80000000000000000007FFF8000
+0000005E537CD167>85 D<00007FFF000000000007FFFFF0000000003FFFFFFE00000000
+FFFFFFFF80000001FFE00FFFC0000003FE0001FFF0000007FF0000FFF8000007FF80003F
+FC00000FFF80003FFE00000FFFC0001FFE00000FFFC0001FFF00000FFFC0000FFF80000F
+FFC0000FFF80000FFFC0000FFF800007FF800007FFC00007FF800007FFC00003FF000007
+FFC00001FE000007FFC0000000000007FFC0000000000007FFC0000000000007FFC00000
+00000007FFC0000000000007FFC0000000000007FFC0000000007FFFFFC00000000FFFFF
+FFC0000000FFFFFFFFC0000007FFFF87FFC000003FFFF007FFC000007FFF8007FFC00001
+FFFC0007FFC00003FFF00007FFC00007FFE00007FFC0000FFFC00007FFC0001FFF800007
+FFC0003FFF000007FFC0007FFF000007FFC0007FFE000007FFC0007FFE000007FFC000FF
+FC000007FFC000FFFC000007FFC000FFFC000007FFC000FFFC000007FFC000FFFC00000F
+FFC000FFFC00000FFFC000FFFE00001FFFC0007FFE00001DFFC0007FFE00003DFFC0003F
+FF000079FFE0001FFF8000F1FFF8000FFFC003E1FFFFE007FFF81FC0FFFFF003FFFFFF80
+7FFFF000FFFFFF001FFFF0001FFFFC0007FFE00001FFE0000000003C387CB641>97
+D<003FF0000000000000FFFFF0000000000000FFFFF0000000000000FFFFF00000000000
+00FFFFF0000000000000FFFFF000000000000003FFF000000000000000FFF00000000000
+0000FFF000000000000000FFF000000000000000FFF000000000000000FFF00000000000
+0000FFF000000000000000FFF000000000000000FFF000000000000000FFF00000000000
+0000FFF000000000000000FFF000000000000000FFF000000000000000FFF00000000000
+0000FFF000000000000000FFF000000000000000FFF000000000000000FFF00000000000
+0000FFF000000000000000FFF000000000000000FFF000000000000000FFF00000000000
+0000FFF000000000000000FFF001FFE000000000FFF00FFFFE00000000FFF03FFFFFC000
+0000FFF0FFFFFFF0000000FFF3FF01FFF8000000FFF7F8003FFE000000FFFFE0000FFF00
+0000FFFF800007FF800000FFFF000003FFC00000FFFE000001FFE00000FFFC000001FFF0
+0000FFF8000000FFF80000FFF8000000FFF80000FFF80000007FFC0000FFF80000007FFC
+0000FFF80000007FFE0000FFF80000007FFE0000FFF80000007FFF0000FFF80000003FFF
+0000FFF80000003FFF0000FFF80000003FFF0000FFF80000003FFF8000FFF80000003FFF
+8000FFF80000003FFF8000FFF80000003FFF8000FFF80000003FFF8000FFF80000003FFF
+8000FFF80000003FFF8000FFF80000003FFF8000FFF80000003FFF8000FFF80000003FFF
+8000FFF80000003FFF8000FFF80000003FFF8000FFF80000003FFF0000FFF80000003FFF
+0000FFF80000003FFF0000FFF80000003FFF0000FFF80000007FFE0000FFF80000007FFE
+0000FFF80000007FFE0000FFF80000007FFC0000FFF8000000FFFC0000FFF8000000FFF8
+0000FFFC000001FFF00000FFFC000001FFF00000FFFE000003FFE00000FFFF000007FFC0
+0000FFFF80000FFF800000FFCFC0001FFF000000FF87F0007FFC000000FF03FE03FFF800
+0000FE00FFFFFFE0000000FC007FFFFF80000000F8001FFFFC00000000000003FFC00000
+0041547BD24B>I<000001FFF8000000001FFFFF80000000FFFFFFF0000003FFFFFFFC00
+000FFFC00FFE00001FFE0001FF00007FFC0003FF8000FFF00007FF8001FFF00007FFC003
+FFE0000FFFC003FFC0000FFFC007FFC0000FFFC00FFF80000FFFC00FFF80000FFFC01FFF
+800007FF801FFF000007FF803FFF000003FF003FFF000001FE007FFF00000000007FFE00
+000000007FFE00000000007FFE0000000000FFFE0000000000FFFE0000000000FFFE0000
+000000FFFE0000000000FFFE0000000000FFFE0000000000FFFE0000000000FFFE000000
+0000FFFE0000000000FFFE0000000000FFFE0000000000FFFE0000000000FFFE00000000
+007FFE00000000007FFF00000000007FFF00000000003FFF00000000003FFF0000000000
+3FFF00000003E01FFF80000003E01FFF80000007E00FFFC0000007C007FFC0000007C007
+FFE000000FC003FFE000001F8001FFF000003F0000FFF800007E00007FFE0000FC00003F
+FF0003F800000FFFE01FF0000003FFFFFFE0000000FFFFFF800000003FFFFE0000000001
+FFE0000033387CB63C>I<000000000001FF80000000000007FFFF80000000000007FFFF
+80000000000007FFFF80000000000007FFFF80000000000007FFFF800000000000001FFF
+8000000000000007FF8000000000000007FF8000000000000007FF8000000000000007FF
+8000000000000007FF8000000000000007FF8000000000000007FF8000000000000007FF
+8000000000000007FF8000000000000007FF8000000000000007FF8000000000000007FF
+8000000000000007FF8000000000000007FF8000000000000007FF8000000000000007FF
+8000000000000007FF8000000000000007FF8000000000000007FF8000000000000007FF
+8000000000000007FF8000000000000007FF8000000001FFE007FF800000001FFFFC07FF
+80000000FFFFFF07FF80000003FFFFFFC7FF8000000FFFE03FE7FF8000001FFF0007F7FF
+8000007FFC0001FFFF800000FFF80000FFFF800001FFF000003FFF800003FFE000001FFF
+800007FFC000001FFF800007FFC000000FFF80000FFF8000000FFF80001FFF8000000FFF
+80001FFF0000000FFF80003FFF0000000FFF80003FFF0000000FFF80003FFF0000000FFF
+80007FFE0000000FFF80007FFE0000000FFF80007FFE0000000FFF80007FFE0000000FFF
+8000FFFE0000000FFF8000FFFE0000000FFF8000FFFE0000000FFF8000FFFE0000000FFF
+8000FFFE0000000FFF8000FFFE0000000FFF8000FFFE0000000FFF8000FFFE0000000FFF
+8000FFFE0000000FFF8000FFFE0000000FFF8000FFFE0000000FFF8000FFFE0000000FFF
+80007FFE0000000FFF80007FFE0000000FFF80007FFE0000000FFF80003FFF0000000FFF
+80003FFF0000000FFF80003FFF0000000FFF80001FFF0000000FFF80001FFF0000000FFF
+80000FFF8000000FFF80000FFF8000001FFF800007FFC000003FFF800003FFC000003FFF
+800001FFE000007FFF800000FFF00001FFFF8000007FF80003FFFFE000003FFE000FEFFF
+FF80000FFFC07FCFFFFF800007FFFFFF8FFFFF800001FFFFFE0FFFFF8000003FFFF80FFF
+FF80000003FFC00FFE000041547CD24B>I<000003FFC0000000003FFFFC00000001FFFF
+FF00000007FFFFFFC000000FFF81FFE000003FFC007FF800007FF8003FFC0000FFF0001F
+FE0001FFE0000FFE0003FFC00007FF0007FFC00007FF800FFF800003FF800FFF800003FF
+C01FFF800001FFC01FFF000001FFC03FFF000001FFE03FFF000001FFE07FFF000000FFE0
+7FFE000000FFE07FFE000000FFF07FFE000000FFF0FFFE000000FFF0FFFE000000FFF0FF
+FE000000FFF0FFFE000000FFF0FFFFFFFFFFFFF0FFFFFFFFFFFFF0FFFFFFFFFFFFF0FFFF
+FFFFFFFFE0FFFE0000000000FFFE0000000000FFFE0000000000FFFE0000000000FFFE00
+00000000FFFE00000000007FFE00000000007FFE00000000007FFF00000000003FFF0000
+0000003FFF00000000003FFF00000000E01FFF00000001F01FFF80000003F00FFF800000
+03F007FFC0000007E007FFC0000007E003FFE000000FC001FFF000001FC000FFF800003F
+80007FFC0000FF00001FFE0003FE00000FFFC03FF8000003FFFFFFF0000000FFFFFFC000
+00001FFFFE0000000001FFF0000034387CB63D>I<0000003FFC00000003FFFF0000000F
+FFFFC000003FFFFFE00000FFF81FF00001FFC03FF80003FF807FF80007FF00FFFC000FFE
+00FFFC001FFC00FFFC001FFC00FFFC003FF800FFFC003FF800FFFC003FF8007FF8007FF0
+007FF8007FF0003FF0007FF0000FC0007FF0000000007FF0000000007FF0000000007FF0
+000000007FF0000000007FF0000000007FF0000000007FF0000000007FF0000000007FF0
+000000007FF0000000007FF0000000007FF0000000007FF0000000FFFFFFFFE000FFFFFF
+FFE000FFFFFFFFE000FFFFFFFFE000FFFFFFFFE000007FF8000000007FF8000000007FF8
+000000007FF8000000007FF8000000007FF8000000007FF8000000007FF8000000007FF8
+000000007FF8000000007FF8000000007FF8000000007FF8000000007FF8000000007FF8
+000000007FF8000000007FF8000000007FF8000000007FF8000000007FF8000000007FF8
+000000007FF8000000007FF8000000007FF8000000007FF8000000007FF8000000007FF8
+000000007FF8000000007FF8000000007FF8000000007FF8000000007FF8000000007FF8
+000000007FF8000000007FF8000000007FF8000000007FF8000000007FF8000000007FF8
+000000007FF8000000007FF8000000007FF8000000007FF80000007FFFFFFE00007FFFFF
+FE00007FFFFFFE00007FFFFFFE00007FFFFFFE00002E547CD329>I<00003FFF0000FF00
+0003FFFFF007FFC0000FFFFFFC1FFFE0003FFFFFFF7FFFE0007FFC0FFFFF9FF000FFE001
+FFF83FF001FFC000FFE03FF003FF80007FF01FF007FF00003FF81FE00FFF00003FFC0FC0
+0FFF00003FFC07801FFE00001FFE00001FFE00001FFE00003FFE00001FFF00003FFE0000
+1FFF00003FFE00001FFF00003FFE00001FFF00003FFE00001FFF00003FFE00001FFF0000
+3FFE00001FFF00003FFE00001FFF00003FFE00001FFF00001FFE00001FFE00001FFE0000
+1FFE00000FFF00003FFC00000FFF00003FFC000007FF00003FF8000003FF80007FF00000
+01FFC000FFE0000000FFE001FFC0000000FFFC0FFF80000001FFFFFFFF00000003EFFFFF
+FC00000003C3FFFFF000000007C03FFF0000000007C000000000000007C0000000000000
+0FC00000000000000FC00000000000000FC00000000000000FE00000000000000FE00000
+000000000FF80000000000000FFE0000000000000FFFFFFFFF00000007FFFFFFFFF80000
+07FFFFFFFFFF000007FFFFFFFFFFC00003FFFFFFFFFFE00001FFFFFFFFFFF00000FFFFFF
+FFFFF800007FFFFFFFFFFC00007FFFFFFFFFFE0001FFFFFFFFFFFF0007FFFFFFFFFFFF00
+0FFE000003FFFF801FF80000003FFF803FF000000007FF807FE000000003FFC07FE00000
+0001FFC0FFC000000001FFC0FFC000000000FFC0FFC000000000FFC0FFC000000000FFC0
+FFC000000000FFC0FFC000000000FFC0FFE000000001FFC07FE000000001FF807FF00000
+0003FF803FF000000003FF001FF800000007FE000FFE0000001FFC0007FF8000007FF800
+03FFE00001FFF00001FFFE001FFFE000007FFFFFFFFF8000000FFFFFFFFC00000001FFFF
+FFE0000000000FFFFC0000003C4F7CB543>I<003FF0000000000000FFFFF00000000000
+00FFFFF0000000000000FFFFF0000000000000FFFFF0000000000000FFFFF00000000000
+0003FFF000000000000000FFF000000000000000FFF000000000000000FFF00000000000
+0000FFF000000000000000FFF000000000000000FFF000000000000000FFF00000000000
+0000FFF000000000000000FFF000000000000000FFF000000000000000FFF00000000000
+0000FFF000000000000000FFF000000000000000FFF000000000000000FFF00000000000
+0000FFF000000000000000FFF000000000000000FFF000000000000000FFF00000000000
+0000FFF000000000000000FFF000000000000000FFF000000000000000FFF0001FFC0000
+0000FFF000FFFFC0000000FFF003FFFFF0000000FFF00FFFFFF8000000FFF01FE07FFC00
+0000FFF03F001FFE000000FFF07C001FFF000000FFF0F0000FFF000000FFF1E0000FFF80
+0000FFF3C0000FFF800000FFF7800007FF800000FFF7800007FFC00000FFFF000007FFC0
+0000FFFE000007FFC00000FFFE000007FFC00000FFFC000007FFC00000FFFC000007FFC0
+0000FFFC000007FFC00000FFFC000007FFC00000FFF8000007FFC00000FFF8000007FFC0
+0000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC0
+0000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC0
+0000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC0
+0000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC0
+0000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC0
+0000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC0
+0000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC0
+00FFFFFFF807FFFFFFC0FFFFFFF807FFFFFFC0FFFFFFF807FFFFFFC0FFFFFFF807FFFFFF
+C0FFFFFFF807FFFFFFC042537BD24B>I<007F000000FF800003FFE00007FFF00007FFF0
+000FFFF8000FFFF8000FFFF8000FFFF8000FFFF8000FFFF8000FFFF80007FFF00007FFF0
+0003FFE00000FF8000007F00000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000003FF000FFFFF0
+00FFFFF000FFFFF000FFFFF000FFFFF00001FFF00000FFF00000FFF00000FFF00000FFF0
+0000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF0
+0000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF0
+0000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF0
+0000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF0
+0000FFF00000FFF000FFFFFFE0FFFFFFE0FFFFFFE0FFFFFFE0FFFFFFE01B547BD325>I<
+003FF000FFFFF000FFFFF000FFFFF000FFFFF000FFFFF00001FFF00000FFF00000FFF000
+00FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF000
+00FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF000
+00FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF000
+00FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF000
+00FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF000
+00FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF000
+00FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF000
+00FFF00000FFF00000FFF00000FFF00000FFF00000FFF000FFFFFFF0FFFFFFF0FFFFFFF0
+FFFFFFF0FFFFFFF01C537BD225>108 D<003FF0001FFC000000FFE00000FFFFF000FFFF
+C00007FFFE0000FFFFF003FFFFF0001FFFFF8000FFFFF00FFFFFF8007FFFFFC000FFFFF0
+1FE07FFC00FF03FFE000FFFFF03F001FFE01F800FFF00003FFF07C001FFF03E000FFF800
+00FFF0F0000FFF0780007FF80000FFF1E0000FFF8F00007FFC0000FFF3C0000FFF9E0000
+7FFC0000FFF7800007FFBC00003FFC0000FFF7800007FFFC00003FFE0000FFFF000007FF
+F800003FFE0000FFFE000007FFF000003FFE0000FFFE000007FFF000003FFE0000FFFC00
+0007FFE000003FFE0000FFFC000007FFE000003FFE0000FFFC000007FFE000003FFE0000
+FFFC000007FFE000003FFE0000FFF8000007FFC000003FFE0000FFF8000007FFC000003F
+FE0000FFF8000007FFC000003FFE0000FFF8000007FFC000003FFE0000FFF8000007FFC0
+00003FFE0000FFF8000007FFC000003FFE0000FFF8000007FFC000003FFE0000FFF80000
+07FFC000003FFE0000FFF8000007FFC000003FFE0000FFF8000007FFC000003FFE0000FF
+F8000007FFC000003FFE0000FFF8000007FFC000003FFE0000FFF8000007FFC000003FFE
+0000FFF8000007FFC000003FFE0000FFF8000007FFC000003FFE0000FFF8000007FFC000
+003FFE0000FFF8000007FFC000003FFE0000FFF8000007FFC000003FFE0000FFF8000007
+FFC000003FFE0000FFF8000007FFC000003FFE0000FFF8000007FFC000003FFE0000FFF8
+000007FFC000003FFE0000FFF8000007FFC000003FFE0000FFF8000007FFC000003FFE00
+00FFF8000007FFC000003FFE0000FFF8000007FFC000003FFE0000FFF8000007FFC00000
+3FFE0000FFF8000007FFC000003FFE0000FFF8000007FFC000003FFE0000FFF8000007FF
+C000003FFE00FFFFFFF807FFFFFFC03FFFFFFEFFFFFFF807FFFFFFC03FFFFFFEFFFFFFF8
+07FFFFFFC03FFFFFFEFFFFFFF807FFFFFFC03FFFFFFEFFFFFFF807FFFFFFC03FFFFFFE67
+367BB570>I<003FF0001FFC000000FFFFF000FFFFC00000FFFFF003FFFFF00000FFFFF0
+0FFFFFF80000FFFFF01FE07FFC0000FFFFF03F001FFE000003FFF07C001FFF000000FFF0
+F0000FFF000000FFF1E0000FFF800000FFF3C0000FFF800000FFF7800007FF800000FFF7
+800007FFC00000FFFF000007FFC00000FFFE000007FFC00000FFFE000007FFC00000FFFC
+000007FFC00000FFFC000007FFC00000FFFC000007FFC00000FFFC000007FFC00000FFF8
+000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8
+000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8
+000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8
+000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8
+000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8
+000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8
+000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8
+000007FFC00000FFF8000007FFC000FFFFFFF807FFFFFFC0FFFFFFF807FFFFFFC0FFFFFF
+F807FFFFFFC0FFFFFFF807FFFFFFC0FFFFFFF807FFFFFFC042367BB54B>I<000001FFE0
+00000000001FFFFE0000000000FFFFFFC000000003FFFFFFF00000000FFF807FFC000000
+1FFC000FFE0000007FF80007FF800000FFF00003FFC00001FFE00001FFE00003FFC00000
+FFF00003FF8000007FF00007FF8000007FF8000FFF0000003FFC000FFF0000003FFC001F
+FF0000003FFE001FFF0000003FFE003FFE0000001FFF003FFE0000001FFF003FFE000000
+1FFF007FFE0000001FFF807FFE0000001FFF807FFE0000001FFF807FFE0000001FFF80FF
+FE0000001FFFC0FFFE0000001FFFC0FFFE0000001FFFC0FFFE0000001FFFC0FFFE000000
+1FFFC0FFFE0000001FFFC0FFFE0000001FFFC0FFFE0000001FFFC0FFFE0000001FFFC0FF
+FE0000001FFFC0FFFE0000001FFFC0FFFE0000001FFFC07FFE0000001FFF807FFE000000
+1FFF807FFE0000001FFF803FFE0000001FFF003FFF0000003FFF003FFF0000003FFF001F
+FF0000003FFE001FFF0000003FFE000FFF0000003FFC000FFF8000007FFC0007FF800000
+7FF80003FFC00000FFF00001FFE00001FFE00000FFF00003FFC000007FF80007FF800000
+3FFE001FFF0000000FFF807FFC00000007FFFFFFF800000000FFFFFFC0000000003FFFFF
+000000000001FFE00000003A387CB643>I<003FF001FFE0000000FFFFF00FFFFE000000
+FFFFF03FFFFFC00000FFFFF0FFFFFFF00000FFFFF3FF01FFF80000FFFFF7F8007FFE0000
+03FFFFE0001FFF000000FFFF80000FFF800000FFFF000007FFC00000FFFE000007FFE000
+00FFFC000003FFF00000FFF8000001FFF80000FFF8000001FFF80000FFF8000000FFFC00
+00FFF8000000FFFC0000FFF8000000FFFE0000FFF80000007FFE0000FFF80000007FFF00
+00FFF80000007FFF0000FFF80000007FFF0000FFF80000007FFF0000FFF80000003FFF80
+00FFF80000003FFF8000FFF80000003FFF8000FFF80000003FFF8000FFF80000003FFF80
+00FFF80000003FFF8000FFF80000003FFF8000FFF80000003FFF8000FFF80000003FFF80
+00FFF80000003FFF8000FFF80000003FFF8000FFF80000003FFF8000FFF80000003FFF00
+00FFF80000007FFF0000FFF80000007FFF0000FFF80000007FFF0000FFF80000007FFE00
+00FFF8000000FFFE0000FFF8000000FFFE0000FFF8000000FFFC0000FFF8000001FFFC00
+00FFF8000001FFF80000FFFC000003FFF00000FFFC000003FFF00000FFFE000007FFE000
+00FFFF00000FFFC00000FFFF80001FFF800000FFFFC0003FFF000000FFFFF000FFFC0000
+00FFFBFE07FFF8000000FFF8FFFFFFE0000000FFF87FFFFF80000000FFF81FFFFC000000
+00FFF803FFC000000000FFF800000000000000FFF800000000000000FFF8000000000000
+00FFF800000000000000FFF800000000000000FFF800000000000000FFF8000000000000
+00FFF800000000000000FFF800000000000000FFF800000000000000FFF8000000000000
+00FFF800000000000000FFF800000000000000FFF800000000000000FFF8000000000000
+00FFF800000000000000FFF8000000000000FFFFFFF80000000000FFFFFFF80000000000
+FFFFFFF80000000000FFFFFFF80000000000FFFFFFF80000000000414D7BB54B>I<007F
+E003FE00FFFFE00FFF80FFFFE03FFFE0FFFFE07FFFF0FFFFE0FE1FF8FFFFE1F83FFC03FF
+E3E03FFE00FFE3C07FFE00FFE7807FFE00FFEF807FFE00FFEF007FFE00FFEE007FFE00FF
+FE003FFC00FFFC003FFC00FFFC001FF800FFFC000FF000FFF800000000FFF800000000FF
+F800000000FFF800000000FFF800000000FFF000000000FFF000000000FFF000000000FF
+F000000000FFF000000000FFF000000000FFF000000000FFF000000000FFF000000000FF
+F000000000FFF000000000FFF000000000FFF000000000FFF000000000FFF000000000FF
+F000000000FFF000000000FFF000000000FFF000000000FFF000000000FFF000000000FF
+F000000000FFF000000000FFF000000000FFF000000000FFF000000000FFF000000000FF
+F0000000FFFFFFFC0000FFFFFFFC0000FFFFFFFC0000FFFFFFFC0000FFFFFFFC00002F36
+7CB537>114 D<0003FFF00F00003FFFFE1F0000FFFFFFFF0003FFFFFFFF0007FF003FFF
+000FF80007FF001FE00001FF003FC00000FF003F8000007F007F8000007F007F0000003F
+007F0000003F00FF0000001F00FF0000001F00FF8000001F00FF8000001F00FFC000001F
+00FFF000000000FFFC00000000FFFFC00000007FFFFF0000007FFFFFF800003FFFFFFF00
+003FFFFFFFC0001FFFFFFFF0000FFFFFFFF80007FFFFFFFC0003FFFFFFFE0000FFFFFFFF
+00003FFFFFFF80000FFFFFFFC00000FFFFFFC0000007FFFFE00000003FFFE000000007FF
+F000000001FFF0780000007FF0F80000003FF0F80000001FF0FC0000001FF0FC0000000F
+F0FC0000000FF0FE0000000FF0FE0000000FE0FF0000000FE0FF8000001FE0FF8000001F
+C0FFC000001FC0FFE000003F80FFF800007F00FFFE0001FE00FFFFC00FFC00FF7FFFFFF8
+00FC1FFFFFE000F807FFFF8000F000FFF800002C387CB635>I<00003E00000000003E00
+000000003E00000000003E00000000003E00000000003E00000000007E00000000007E00
+000000007E00000000007E0000000000FE0000000000FE0000000001FE0000000001FE00
+00000001FE0000000003FE0000000007FE0000000007FE000000000FFE000000001FFE00
+0000003FFE00000000FFFE00000001FFFE0000000FFFFFFFFF00FFFFFFFFFF00FFFFFFFF
+FF00FFFFFFFFFF00FFFFFFFFFF00003FFE000000003FFE000000003FFE000000003FFE00
+0000003FFE000000003FFE000000003FFE000000003FFE000000003FFE000000003FFE00
+0000003FFE000000003FFE000000003FFE000000003FFE000000003FFE000000003FFE00
+0000003FFE000000003FFE000000003FFE000000003FFE000000003FFE000000003FFE00
+0000003FFE000000003FFE000000003FFE000000003FFE000000003FFE000000003FFE00
+07C0003FFE0007C0003FFE0007C0003FFE0007C0003FFE0007C0003FFE0007C0003FFE00
+07C0003FFE0007C0003FFE0007C0003FFE0007C0003FFE0007C0001FFE000F80001FFF00
+0F80001FFF000F80000FFF001F00000FFF801F000007FFC03E000003FFF0FC000001FFFF
+F80000007FFFF00000001FFFE000000003FF80002A4D7ECB34>I<003FF8000001FFC000
+FFFFF80007FFFFC000FFFFF80007FFFFC000FFFFF80007FFFFC000FFFFF80007FFFFC000
+FFFFF80007FFFFC00003FFF800001FFFC00000FFF8000007FFC00000FFF8000007FFC000
+00FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC000
+00FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC000
+00FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC000
+00FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC000
+00FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC000
+00FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC000
+00FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC000
+00FFF8000007FFC00000FFF8000007FFC00000FFF800000FFFC00000FFF800000FFFC000
+00FFF800000FFFC00000FFF800001FFFC00000FFF800001FFFC000007FF800003FFFC000
+007FF800003BFFC000007FF800007BFFC000003FFC0000F3FFC000003FFC0001E3FFF000
+001FFE0007C3FFFFC0000FFFC03F83FFFFC00007FFFFFF03FFFFC00001FFFFFE03FFFFC0
+00007FFFF803FFFFC0000007FFE003FF000042377BB54B>I<FFFFFFF00007FFFFFFFFFF
+F00007FFFFFFFFFFF00007FFFFFFFFFFF00007FFFFFFFFFFF00007FFFF01FFF80000007F
+E000FFFC0000003F0000FFFC0000003F00007FFC0000003E00007FFE0000007E00003FFE
+0000007C00003FFF000000FC00001FFF000000F800001FFF800001F800000FFF800001F0
+00000FFFC00001F000000FFFC00003F0000007FFC00003E0000007FFE00007E0000003FF
+E00007C0000003FFF0000FC0000001FFF0000F80000001FFF8001F80000000FFF8001F00
+000000FFFC001F00000000FFFC003F000000007FFE003E000000007FFE007E000000003F
+FE007C000000003FFF00FC000000001FFF00F8000000001FFF81F8000000000FFF81F000
+0000000FFFC3F0000000000FFFC3F00000000007FFE3E00000000007FFE7E00000000003
+FFE7C00000000003FFFFC00000000001FFFF800000000001FFFF800000000000FFFF0000
+00000000FFFF0000000000007FFE0000000000007FFE0000000000007FFE000000000000
+3FFC0000000000003FFC0000000000001FF80000000000001FF80000000000000FF00000
+000000000FF000000000000007E000000000000003C000000040367DB447>I<FFFFFFE0
+7FFFFFC003FFFFC0FFFFFFE07FFFFFC003FFFFC0FFFFFFE07FFFFFC003FFFFC0FFFFFFE0
+7FFFFFC003FFFFC0FFFFFFE07FFFFFC003FFFFC001FFF00000FFF000001FF80001FFF800
+007FF0000007E00000FFF800007FF8000007C00000FFF800007FF8000007C00000FFFC00
+003FF800000FC000007FFC00003FFC00000F8000007FFC00003FFC00000F8000007FFE00
+003FFC00001F8000003FFE00007FFE00001F0000003FFF00007FFE00003F0000001FFF00
+007FFF00003E0000001FFF0000FFFF00003E0000001FFF8000FFFF00007E0000000FFF80
+01FFFF80007C0000000FFFC001F3FF8000FC00000007FFC001F3FFC000F800000007FFC0
+03F3FFC000F800000007FFE003E1FFC001F800000003FFE007E1FFE001F000000003FFF0
+07C0FFE001F000000001FFF007C0FFF003E000000001FFF00FC0FFF003E000000001FFF8
+0F807FF007E000000000FFF80F807FF807C000000000FFF81F003FF807C000000000FFFC
+1F003FF80FC0000000007FFC3F003FFC0F80000000007FFE3E001FFC1F80000000003FFE
+3E001FFE1F00000000003FFE7E001FFE1F00000000003FFF7C000FFE3F00000000001FFF
+FC000FFF3E00000000001FFFF80007FF7E00000000000FFFF80007FFFC00000000000FFF
+F80007FFFC00000000000FFFF00003FFFC000000000007FFF00003FFF8000000000007FF
+E00001FFF8000000000003FFE00001FFF0000000000003FFE00001FFF0000000000003FF
+C00000FFF0000000000001FFC00000FFE0000000000001FF8000007FE0000000000001FF
+8000007FE0000000000000FF8000007FC0000000000000FF0000003FC00000000000007F
+0000003F800000000000007F0000003F800000000000003E0000001F000000005A367DB4
+61>I<7FFFFFF0007FFFFE007FFFFFF0007FFFFE007FFFFFF0007FFFFE007FFFFFF0007F
+FFFE007FFFFFF0007FFFFE00007FFE00000FFF0000003FFF000007F80000001FFF800007
+F00000000FFFC0000FE000000007FFC0001FC000000007FFE0003F8000000003FFF0003F
+0000000001FFF8007E0000000000FFFC00FC00000000007FFE01FC00000000007FFE03F8
+00000000003FFF07F000000000001FFF8FE000000000000FFFCFC0000000000007FFFF80
+000000000003FFFF00000000000003FFFF00000000000001FFFE00000000000000FFFC00
+0000000000007FFE000000000000003FFF000000000000003FFF000000000000001FFF80
+0000000000001FFFC00000000000003FFFE00000000000007FFFF0000000000000FFFFF0
+000000000001FDFFF8000000000001F8FFFC000000000003F07FFE000000000007E03FFF
+00000000000FE01FFF00000000001FC01FFF80000000003F800FFFC0000000007F0007FF
+E000000000FE0003FFF000000000FC0001FFF800000001F80001FFF800000003F00000FF
+FC00000007F000007FFE0000000FE000003FFF0000001FC000001FFF800000FFF000001F
+FF8000FFFFFE0001FFFFFFC0FFFFFE0001FFFFFFC0FFFFFE0001FFFFFFC0FFFFFE0001FF
+FFFFC0FFFFFE0001FFFFFFC042357EB447>I<FFFFFFF00007FFFFFFFFFFF00007FFFFFF
+FFFFF00007FFFFFFFFFFF00007FFFFFFFFFFF00007FFFF00FFF80000007FE000FFFC0000
+003F0000FFFC0000003F00007FFE0000003E00007FFE0000007E00003FFE0000007C0000
+3FFF000000FC00001FFF000000F800001FFF800001F800000FFF800001F000000FFFC000
+03F0000007FFC00003E0000007FFE00003E0000007FFE00007E0000003FFF00007C00000
+03FFF0000FC0000001FFF8000F80000001FFF8001F80000000FFF8001F00000000FFFC00
+3F000000007FFC003E000000007FFE007E000000003FFE007C000000003FFF00FC000000
+003FFF00FC000000001FFF80F8000000001FFF81F8000000000FFFC1F0000000000FFFC3
+F00000000007FFC3E00000000007FFE7E00000000003FFE7C00000000003FFFFC0000000
+0001FFFF800000000001FFFF800000000000FFFF000000000000FFFF000000000000FFFF
+0000000000007FFE0000000000007FFE0000000000003FFC0000000000003FFC00000000
+00001FF80000000000001FF80000000000000FF00000000000000FF000000000000007E0
+00000000000007E000000000000007E000000000000007C00000000000000FC000000000
+00000F800000000000001F800000000000001F000000000000003F000000001FC0003E00
+0000003FE0007E000000007FF0007C00000000FFF800FC00000000FFF800F800000000FF
+F801F800000000FFF801F000000000FFF803F000000000FFF807E0000000007FF00FC000
+0000007FE01F80000000003FC07F00000000003F81FE00000000001FFFFC00000000000F
+FFF0000000000003FFE0000000000000FF000000000000404D7DB447>I
+E /Fl 32 122 df<3C007E00FF00FF00FF80FF807F803D80018001800180018003800300
+0300070006000E000C001C0038007000600009177A8715>44 D<FFFFF0FFFFF0FFFFF0FF
+FFF0FFFFF014057F921A>I<3C7EFFFFFFFF7E3C08087A8715>I<000001C000000001C000
+000003C000000007C000000007C00000000FC00000001FC00000001FC00000003FC00000
+007FC00000006FC0000000CFC0000001CFC00000038FC00000030FC00000070FC000000E
+0FC000000C0FC000001C0FC00000380FC00000300FC00000700FC00000E00FC00000C00F
+C00001800FC00003800FC00003000FC00006000FC0000E000FC0000C000FC00018000FC0
+0038000FC00030000FC00060000FC000E0000FC000FFFFFFFF80FFFFFFFF80FFFFFFFF80
+00000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000
+000FC00000000FC00000001FE0000007FFFF800007FFFF800007FFFF8021337EB226>52
+D<000FE000007FFC0000FFFF0003F01F8007C007C00F0003E00E0001F01E0000F01C0000
+F83C0000783C0000783C0000783E0000783E0000783F0000F83F8000F03FC001F01FF001
+E01FF803C00FFE078007FF0F0003FFDE0001FFF80000FFF800003FFE00003FFF0000F7FF
+C003E3FFE00780FFF00F007FF81E001FF83E0007FC3C0003FC780001FC7800007EF80000
+7EF000003EF000003EF000001EF000001EF000001EF800001EF800003C7800003C7C0000
+783E0000781F0000F00F8003E007F01FC001FFFF00007FFC00001FE0001F347DB126>56
+D<000003FE000C00003FFF801C0000FFFFE01C0003FE01F83C000FF0003C7C001FC0000E
+FC007F800007FC00FE000003FC01FC000001FC03FC000000FC03F8000000FC07F0000000
+7C0FE00000007C0FE00000003C1FC00000003C1FC00000001C3FC00000001C3F80000000
+1C7F800000000C7F800000000C7F800000000C7F000000000CFF0000000000FF00000000
+00FF0000000000FF0000000000FF0000000000FF0000000000FF0000000000FF00000000
+00FF0000000000FF0000000000FF00000000007F00000000007F800000000C7F80000000
+0C7F800000000C3F800000000C3FC00000000C1FC00000001C1FC0000000180FE0000000
+180FE00000003807F00000003003F80000007003FC000000E001FC000000E000FE000001
+C0007F80000380001FC0000F00000FF0001E000003FE00FC000000FFFFF00000003FFFC0
+00000003FE00002E377CB437>67 D<FFFE00001FFFF8FFFF00001FFFF8FFFF80001FFFF8
+00FF800000FF0000FFC000003C0000DFE00000180000CFF00000180000CFF00000180000
+C7F80000180000C3FC0000180000C3FC0000180000C1FE0000180000C0FF0000180000C0
+7F8000180000C07F8000180000C03FC000180000C01FE000180000C01FE000180000C00F
+F000180000C007F800180000C003FC00180000C003FC00180000C001FE00180000C000FF
+00180000C000FF00180000C0007F80180000C0003FC0180000C0001FE0180000C0001FE0
+180000C0000FF0180000C00007F8180000C00007F8180000C00003FC180000C00001FE18
+0000C00000FF180000C00000FF180000C000007F980000C000003FD80000C000003FD800
+00C000001FF80000C000000FF80000C0000007F80000C0000007F80000C0000003F80000
+C0000001F80000C0000001F80001E0000000F80007F80000007800FFFFC000003800FFFF
+C000003800FFFFC00000180035337EB23A>78 D<001FE00300007FFC070001FFFF070007
+F01FCF000F8003FF001F0000FF003E00007F003E00003F007C00001F007C00001F007800
+000F00F800000700F800000700F800000700F800000700FC00000300FC00000300FE0000
+0300FE000000007F000000007FC00000003FF00000003FFF0000001FFFF000000FFFFF00
+0007FFFFC00003FFFFF00000FFFFF800003FFFFC000003FFFE0000003FFF00000003FF00
+000000FF800000007F800000003F800000001FC00000000FC0C000000FC0C000000FC0C0
+000007C0C0000007C0C0000007C0E0000007C0E0000007C0F000000F80F000000F80F800
+000F00FC00001F00FE00003E00FF00007E00FFC000FC00F1FC03F800E0FFFFE000E01FFF
+8000C003FE000022377CB42B>83 D<7FFFFFFFFFFE7FFFFFFFFFFE7FFFFFFFFFFE7F8007
+F001FE7C0007F0003E780007F0001E700007F0000E700007F0000E600007F00006E00007
+F00007E00007F00007E00007F00007C00007F00003C00007F00003C00007F00003C00007
+F00003C00007F00003C00007F00003000007F00000000007F00000000007F00000000007
+F00000000007F00000000007F00000000007F00000000007F00000000007F00000000007
+F00000000007F00000000007F00000000007F00000000007F00000000007F00000000007
+F00000000007F00000000007F00000000007F00000000007F00000000007F00000000007
+F00000000007F00000000007F00000000007F00000000007F00000000007F00000000007
+F00000000007F0000000000FF80000001FFFFFFC00001FFFFFFC00001FFFFFFC0030337D
+B237>I<007F80000003FFF000000F80FC00001C003E00003F003F00003F801F80003F80
+0FC0003F800FC0003F8007E0001F0007E000000007E000000007E000000007E000000007
+E0000001FFE000001FFFE00000FF87E00003FC07E0000FF007E0001FC007E0003F8007E0
+007F8007E0007F0007E000FF0007E0C0FE0007E0C0FE0007E0C0FE0007E0C0FE000FE0C0
+FE000FE0C0FF001FE0C07F003BE0C03F8071F1801FC1E1FF8007FFC0FF0000FE003C0022
+237DA126>97 D<03F0000000FFF0000000FFF0000000FFF000000007F000000003F00000
+0003F000000003F000000003F000000003F000000003F000000003F000000003F0000000
+03F000000003F000000003F000000003F000000003F000000003F000000003F03F800003
+F0FFE00003F3C0F80003F7007E0003FE003F0003FC001F8003F8000FC003F0000FC003F0
+0007E003F00007F003F00007F003F00003F003F00003F803F00003F803F00003F803F000
+03F803F00003F803F00003F803F00003F803F00003F803F00003F803F00003F803F00003
+F003F00007F003F00007E003F00007E003F0000FC003F8000FC003FC001F8003EC003F00
+03CF007C00038381F8000301FFE00000007F000025357EB32B>I<0007F800003FFF0000
+FC07C001F000E003E003F007C007F00FC007F01F8007F03F8007F03F0003E07F0000007F
+0000007E000000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE
+000000FE000000FE0000007F0000007F0000003F0000183F8000181F8000381FC000300F
+C0007007E000E003F001C000FC0F80003FFE000007F0001D237EA122>I<0000003F0000
+000FFF0000000FFF0000000FFF000000007F000000003F000000003F000000003F000000
+003F000000003F000000003F000000003F000000003F000000003F000000003F00000000
+3F000000003F000000003F000000003F000007F03F00003FFC3F0000FC0F3F0001F003BF
+0007E001FF000FC000FF001F80007F001F80003F003F00003F003F00003F007F00003F00
+7E00003F00FE00003F00FE00003F00FE00003F00FE00003F00FE00003F00FE00003F00FE
+00003F00FE00003F00FE00003F00FE00003F007E00003F007F00003F007F00003F003F00
+003F001F80007F001F80007F000FC000FF0007E001FF8003F007BFFC00F81E3FFC003FFC
+3FFC000FE03F0026357DB32B>I<000FE000007FFC0000F83F0003F00F8007E00FC00FC0
+07E01F8003E01F8003F03F0003F03F0001F07F0001F87E0001F87E0001F8FE0001F8FE00
+01F8FFFFFFF8FFFFFFF8FE000000FE000000FE000000FE000000FE0000007E0000007F00
+00007F0000003F0000183F0000181F8000380F8000300FC0007007E000E001F003C000FC
+0F00003FFE000007F0001D237EA122>I<0001FC000007FF00001F0780003E0FC0007C1F
+C000FC1FC001F81FC001F81FC003F8070003F0000003F0000003F0000003F0000003F000
+0003F0000003F0000003F0000003F0000003F0000003F0000003F00000FFFFF000FFFFF0
+00FFFFF00003F0000003F0000003F0000003F0000003F0000003F0000003F0000003F000
+0003F0000003F0000003F0000003F0000003F0000003F0000003F0000003F0000003F000
+0003F0000003F0000003F0000003F0000003F0000003F0000003F0000003F0000007F800
+007FFFE0007FFFE0007FFFE0001A357FB417>I<0000001F00001FC07F8000FFF8E3C001
+F07FC7C007E03F03C00FC01F83800F800F80001F800FC0001F0007C0003F0007E0003F00
+07E0003F0007E0003F0007E0003F0007E0003F0007E0001F0007C0001F800FC0000F800F
+80000FC01F800007E03F000007F07C00000EFFF800000C1FC000001C000000001C000000
+001C000000001E000000001E000000001F000000000FFFFE00000FFFFFC00007FFFFF000
+03FFFFFC0007FFFFFE001F0001FE003E00007F007C00003F007C00001F80F800000F80F8
+00000F80F800000F80F800000F80F800000F80FC00001F807C00001F003E00003E001F00
+007C000FC001F80003F007E00000FFFF8000001FFC000022337EA126>I<03F0000000FF
+F0000000FFF0000000FFF000000007F000000003F000000003F000000003F000000003F0
+00000003F000000003F000000003F000000003F000000003F000000003F000000003F000
+000003F000000003F000000003F000000003F01FC00003F07FF00003F1E0FC0003F3807C
+0003F7007E0003FE007E0003FC003F0003FC003F0003F8003F0003F8003F0003F0003F00
+03F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003
+F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0
+003F0003F0003F0003F0003F0003F0003F0007F8007F80FFFFC7FFFCFFFFC7FFFCFFFFC7
+FFFC26347EB32B>I<07800FC01FE01FE01FE01FE00FC007800000000000000000000000
+00000000000000000007E0FFE0FFE0FFE00FE007E007E007E007E007E007E007E007E007
+E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007E00FF0FFFFFF
+FFFFFF10337EB215>I<03F0000000FFF0000000FFF0000000FFF000000007F000000003
+F000000003F000000003F000000003F000000003F000000003F000000003F000000003F0
+00000003F000000003F000000003F000000003F000000003F000000003F000000003F000
+000003F003FFE003F003FFE003F003FFE003F001FF0003F000F80003F001E00003F001C0
+0003F003800003F00F000003F01C000003F038000003F070000003F0F0000003F3F80000
+03F7FC000003FEFC000003FC7E000003F87F000003F03F800003F01F800003F00FC00003
+F00FE00003F007E00003F003F00003F003F80003F001F80003F000FC0003F000FE0007F8
+00FF80FFFFC3FFF0FFFFC3FFF0FFFFC3FFF024347EB329>107 D<07E0FFE0FFE0FFE00F
+E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007
+E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007
+E007E007E007E007E007E007E007E00FF0FFFFFFFFFFFF10347EB315>I<03F01FE000FF
+0000FFF07FF803FFC000FFF1E07C0F03E000FFF3803E1C01F00007F7003F3801F80003FE
+003F7001F80003FC001FE000FC0003FC001FE000FC0003F8001FC000FC0003F8001FC000
+FC0003F0001F8000FC0003F0001F8000FC0003F0001F8000FC0003F0001F8000FC0003F0
+001F8000FC0003F0001F8000FC0003F0001F8000FC0003F0001F8000FC0003F0001F8000
+FC0003F0001F8000FC0003F0001F8000FC0003F0001F8000FC0003F0001F8000FC0003F0
+001F8000FC0003F0001F8000FC0003F0001F8000FC0003F0001F8000FC0003F0001F8000
+FC0003F0001F8000FC0007F8003FC001FE00FFFFC7FFFE3FFFF0FFFFC7FFFE3FFFF0FFFF
+C7FFFE3FFFF03C217EA041>I<03F01FC000FFF07FF000FFF1E0FC00FFF3807C0007F700
+7E0003FE007E0003FC003F0003FC003F0003F8003F0003F8003F0003F0003F0003F0003F
+0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F00
+03F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003
+F0003F0003F0003F0003F0003F0007F8007F80FFFFC7FFFCFFFFC7FFFCFFFFC7FFFC2621
+7EA02B>I<0007F00000003FFE000000FC1F800001F007C00003C001E00007C001F0000F
+8000F8001F00007C001F00007C003F00007E003E00003E007E00003F007E00003F007E00
+003F00FE00003F80FE00003F80FE00003F80FE00003F80FE00003F80FE00003F80FE0000
+3F80FE00003F807E00003F007E00003F007E00003F003F00007E003F00007E001F00007C
+001F8000FC000FC001F80007C001F00003F007E00000FC1F8000003FFE00000007F00000
+21237EA126>I<03F03F8000FFF0FFE000FFF3C0F800FFF7007E0007FE003F0003FC001F
+8003F8001FC003F0000FC003F0000FE003F00007F003F00007F003F00007F003F00003F8
+03F00003F803F00003F803F00003F803F00003F803F00003F803F00003F803F00003F803
+F00003F803F00007F803F00007F003F00007F003F00007E003F0000FE003F0000FC003F8
+001FC003FC003F8003FC003F0003FF00FC0003F381F80003F1FFE00003F07F000003F000
+000003F000000003F000000003F000000003F000000003F000000003F000000003F00000
+0003F000000003F000000007F8000000FFFFC00000FFFFC00000FFFFC0000025307EA02B
+>I<03E07C00FFE1FF00FFE38F80FFE71FC007EE1FC003EC1FC003EC1FC003FC0F8003F8
+000003F8000003F8000003F0000003F0000003F0000003F0000003F0000003F0000003F0
+000003F0000003F0000003F0000003F0000003F0000003F0000003F0000003F0000003F0
+000003F0000003F0000007F80000FFFFE000FFFFE000FFFFE0001A217FA01E>114
+D<00FF060007FFCE001F00FE003C003E0078001E0078000E00F0000E00F0000600F00006
+00F8000600F8000600FE000000FF8000007FFC00003FFFC0003FFFF0000FFFF80007FFFC
+0000FFFE00000FFF000000FF0000003F80C0001F80C0000F80E0000780E0000780E00007
+80F0000780F0000700F8000F00FC000E00FE001C00F7807800E1FFE000C07F800019237E
+A11E>I<00300000300000300000300000300000700000700000700000F00000F00001F0
+0001F00003F00007F0001FFFFEFFFFFEFFFFFE03F00003F00003F00003F00003F00003F0
+0003F00003F00003F00003F00003F00003F00003F00003F00003F00003F00303F00303F0
+0303F00303F00303F00303F00303F00303F00701F80601F80600FC0E007E1C001FF80007
+E0182F7FAD1E>I<03F0003F00FFF00FFF00FFF00FFF00FFF00FFF0007F0007F0003F000
+3F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F
+0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F00
+03F0003F0003F0003F0003F0003F0003F0003F0003F0007F0003F0007F0003F0007F0003
+F000FF0001F000FF0001F801FF8000F803BFFC007E073FFC001FFE3FFC0007F83F002622
+7EA02B>I<FFFF00FFF0FFFF00FFF0FFFF00FFF00FF0003F8007F0001F0003F0000E0003
+F0000C0003F8001C0001F800180001F800180000FC00300000FC00300000FE007000007E
+006000007F006000003F00C000003F00C000001F818000001F818000001FC38000000FC3
+0000000FC300000007E600000007E600000007FE00000003FC00000003FC00000001F800
+000001F800000001F800000000F000000000F00000000060000024217E9F29>I<FFFF1F
+FF81FFF0FFFF1FFF81FFF0FFFF1FFF81FFF007F801FC003F8007F001F8001E0003F000F8
+001C0003F000FC001C0001F8007C00180001F8007C00180001FC007E00380000FC00FE00
+300000FC00FE003000007E01FF006000007E019F006000007E019F806000003F030F80C0
+00003F030F80C000003F030FC0C000001F8607C18000001F8607C18000001FC607E38000
+000FCC03E30000000FCC03E300000007FC03F600000007F801F600000007F801FE000000
+03F000FC00000003F000FC00000003F000FC00000001E0007800000001E0007800000001
+E0007800000000C00030000034217F9F37>I<FFFF01FFF8FFFF01FFF8FFFF01FFF803FE
+00FF8001FC007C0000FC007800007E007000007F00E000003F81C000001F838000000FC3
+00000007E600000007FE00000003FC00000001F800000000FC00000000FE00000000FF00
+000001FF000000039F800000071FC00000060FE000000C07E000001C03F000003801F800
+007001FC0000F000FC0001F000FE000FF000FF80FFFC03FFFCFFFC03FFFCFFFC03FFFC26
+207F9F29>I<7FFF807FF87FFF807FF87FFF807FF807F8001FC003F8000F8001F8000700
+01F800060000FC000C0000FC000C0000FE001C00007E001800007E001800003F00300000
+3F003000003F807000001F806000001FC0E000000FC0C000000FC0C0000007E180000007
+E180000007F380000003F300000003FB00000001FE00000001FE00000000FC00000000FC
+00000000FC00000000780000000078000000003000000000300000000060000000006000
+000000E000000000C000000000C0000000018000007801800000FC03000000FC03000000
+FC06000000FC0E000000701C00000078380000001FF00000000FC000000025307F9F29>
+I E /Fm 7 117 df<0000001F800000000000001F800000000000003FC0000000000000
+3FC00000000000007FE00000000000007FE00000000000007FE0000000000000FFF00000
+00000000FFF0000000000001FFF8000000000001FFF8000000000001FFF8000000000003
+FFFC000000000003FFFC000000000007FFFE000000000007CFFE000000000007CFFE0000
+0000000FCFFF00000000000F87FF00000000001F87FF80000000001F03FF80000000003F
+03FFC0000000003E01FFC0000000003E01FFC0000000007E01FFE0000000007C00FFE000
+000000FC00FFF000000000F8007FF000000000F8007FF000000001F8007FF800000001F0
+003FF800000003F0003FFC00000003E0001FFC00000003E0001FFC00000007FFFFFFFE00
+000007FFFFFFFE0000000FFFFFFFFF0000000FFFFFFFFF0000001F800007FF8000001F00
+0003FF8000001F000003FF8000003F000003FFC000003E000001FFC000007E000001FFE0
+00007C000000FFE000007C000000FFE00000FC000000FFF00000F80000007FF000FFFFF0
+003FFFFFF0FFFFF0003FFFFFF0FFFFF0003FFFFFF0FFFFF0003FFFFFF03C347DB343>65
+D<007FFE000003FFFFE00007FFFFF8000FF00FFC001FF803FF001FF801FF001FF800FF80
+1FF800FFC01FF8007FC00FF0007FC007E0007FC00180007FC00000007FC000007FFFC000
+0FFFFFC000FFFFFFC003FFF07FC00FFF007FC01FF8007FC03FF0007FC07FE0007FC0FFC0
+007FC0FF80007FC0FF80007FC0FF80007FC0FF8000FFC0FFC000FFC07FC001FFC07FE003
+FFE03FF80FBFFF0FFFFF1FFF03FFFC0FFF007FE007FF28217EA02B>97
+D<01FC00000000FFFC00000000FFFC00000000FFFC00000000FFFC000000000FFC000000
+0007FC0000000007FC0000000007FC0000000007FC0000000007FC0000000007FC000000
+0007FC0000000007FC0000000007FC0000000007FC0000000007FC0000000007FC000000
+0007FC0000000007FC07FC000007FC7FFF800007FDFFFFE00007FFF00FF80007FFC007FC
+0007FF0003FE0007FE0001FF0007FC0000FF8007FC0000FF8007FC0000FFC007FC00007F
+C007FC00007FC007FC00007FE007FC00007FE007FC00007FE007FC00007FE007FC00007F
+E007FC00007FE007FC00007FE007FC00007FE007FC00007FE007FC00007FC007FC00007F
+C007FC0000FFC007FC0000FF8007FC0000FF8007FE0001FF0007FF0003FE0007FFC007FC
+0007F3F01FF80007E1FFFFE00007C07FFF800007800FF800002B347EB331>I<0007FF80
+00003FFFF00000FFFFFC0003FE01FE0007FC03FF000FF803FF001FF003FF003FE003FF00
+3FE003FF007FE001FE007FC000FC007FC0003000FFC0000000FFC0000000FFC0000000FF
+C0000000FFC0000000FFC0000000FFC0000000FFC0000000FFC00000007FC00000007FE0
+0000007FE00000003FE00007803FF00007801FF8000F800FF8001F0007FE003E0003FF80
+FC0000FFFFF800003FFFE0000007FF000021217DA027>I<01F81F80FFF87FF0FFF8FFF8
+FFF9E3FCFFFBC7FE0FFF87FE07FF07FE07FF07FE07FE07FE07FE03FC07FE01F807FE0060
+07FC000007FC000007FC000007FC000007FC000007FC000007FC000007FC000007FC0000
+07FC000007FC000007FC000007FC000007FC000007FC000007FC000007FC0000FFFFF000
+FFFFF000FFFFF000FFFFF0001F217EA024>114 D<00FFE1C007FFFFC00FFFFFC03F803F
+C07E000FC07E0007C0FC0007C0FC0003C0FE0003C0FE0003C0FF800000FFFC0000FFFFE0
+007FFFFC007FFFFE003FFFFF800FFFFFC007FFFFE000FFFFE0000FFFF000007FF000000F
+F0F00007F0F00003F0F80003F0F80003F0FC0003E0FE0007E0FF000FC0FFC01F80FFFFFF
+00F9FFFC00E03FE0001C217DA023>I<003C0000003C0000003C0000003C0000003C0000
+007C0000007C0000007C000000FC000000FC000001FC000001FC000003FC000007FC0000
+1FFFFF80FFFFFF80FFFFFF80FFFFFF8007FC000007FC000007FC000007FC000007FC0000
+07FC000007FC000007FC000007FC000007FC000007FC000007FC000007FC000007FC0000
+07FC000007FC000007FC03C007FC03C007FC03C007FC03C007FC03C007FC03C007FC03C0
+07FE078003FE078001FF0F0000FFFE00003FFC00000FF0001A2F7EAE22>I
+E /Fn 24 122 df<7FFFFFF8FFFFFFFCFFFFFFFCFFFFFFFCFFFFFFFC7FFFFFF81E067C99
+27>45 D<1E007F807F80FFC0FFC0FFC0FFC07F807F801E000A0A728927>I<0001FE0000
+07FF80001FFFC0007FFFE000FFFFF001FF03F803FC01F807F000FC0FE01F7C0FC07FFE1F
+80FFFE1F01FFFE3F03FFFE3E07F1FF7E07E0FF7C0FC07F7C0F803F7C0F803FFC1F803FF8
+1F001FF81F001FF81F001FF81F001FF81F001FF81F001FF81F001FF81F001FFC1F803F7C
+0F803E7C0F803E7C0FC07E7E07E0FC3E07F1FC3F03FFF81F01FFF01F80FFE00FC07FC00F
+E01F1E07F0003F03FC007F01FF03FF00FFFFFE007FFFFC001FFFF00007FFC00001FF0020
+2E7DAD27>64 D<03FFC000000FFFF000001FFFFC00003FFFFF00003FFFFF80003F80FF80
+003F801FC0001F000FC00004000FE000000007E000000007E000000FFFE000007FFFE000
+03FFFFE0000FFFFFE0001FFFFFE0003FFC07E0007FC007E0007F0007E000FE0007E000FC
+0007E000FC0007E000FC0007E000FC0007E000FE000FE0007F001FE0007FC0FFE0003FFF
+FFFF801FFFFFFFC00FFFFFFFC003FFF1FFC000FF807F8022207C9F27>97
+D<7FE0000000FFF0000000FFF0000000FFF00000007FF000000003F000000003F0000000
+03F000000003F000000003F000000003F000000003F000000003F000000003F000000003
+F0FF000003F3FFC00003FFFFF00003FFFFF80003FFFFFC0003FF81FE0003FE00FF0003FC
+003F8003F8001F8003F8001FC003F0000FC003F0000FC003F0000FE003F00007E003F000
+07E003F00007E003F00007E003F00007E003F00007E003F0000FE003F0000FC003F8000F
+C003F8001FC003FC003F8003FC007F8003FE00FF0003FF83FE0003FFFFFC0003FFFFF800
+03FFFFF00003F3FFC00001E0FE0000232E7FAD27>I<000FFF00007FFFC001FFFFE003FF
+FFF007FFFFF00FF807F01FE007F03FC003E03F8000807F0000007E0000007E000000FE00
+0000FC000000FC000000FC000000FC000000FC000000FC000000FE0000007E0000007E00
+00007F0000F03F8001F83FC001F81FE003F80FF80FF007FFFFF003FFFFE001FFFFC0007F
+FF00000FF8001D207B9F27>I<00003FF00000007FF80000007FF80000007FF80000003F
+F800000001F800000001F800000001F800000001F800000001F800000001F800000001F8
+00000001F800000001F800000FE1F800007FFDF80001FFFFF80003FFFFF80007FFFFF800
+0FF83FF8001FE00FF8003FC007F8003F8003F8007F0003F8007E0001F8007E0001F800FE
+0001F800FC0001F800FC0001F800FC0001F800FC0001F800FC0001F800FC0001F800FE00
+01F8007E0003F8007E0003F8007F0003F8003F0007F8003F800FF8001FE01FF8000FF03F
+F80007FFFFFFC003FFFFFFE001FFFDFFE0007FF9FFE0001FE0FFC0232E7EAD27>I<000F
+F800003FFE0000FFFF8003FFFFC007FFFFE00FFC0FF01FE003F81FC001F83F8001FC7F00
+00FC7E0000FC7E00007EFE00007EFFFFFFFEFFFFFFFEFFFFFFFEFFFFFFFEFFFFFFFCFC00
+0000FE0000007E0000007F0000003F00003C3F80007E1FC0007E1FF000FE0FFC07FC07FF
+FFFC01FFFFF800FFFFF0003FFFC00007FE001F207D9F27>I<00001FF00000FFF80001FF
+FC0003FFFE0007FFFE000FF0FE000FC0FE001FC07C001F8000001F8000001F8000001F80
+00001F8000001F80007FFFFFF0FFFFFFF8FFFFFFF8FFFFFFF87FFFFFF0001F8000001F80
+00001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F80
+00001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F80
+00001F8000001F80003FFFFFC07FFFFFE07FFFFFE07FFFFFE03FFFFFC01F2E7EAD27>I<
+0000003F00001FC0FF80007FF3FFC001FFFFFFE003FFFFFFE007FFFFEFE00FF07F87E01F
+C01FC3C01FC01FC0001F800FC0003F0007E0003F0007E0003F0007E0003F0007E0003F00
+07E0003F0007E0001F800FC0001FC01FC0001FC01FC0000FF07F80000FFFFF00000FFFFE
+00001FFFFC00001F7FF000001F1FC000001F000000001F000000001F800000000FFFFF00
+000FFFFFE0000FFFFFF8001FFFFFFE003FFFFFFF003F8001FF007E00003F807C00000F80
+FC00000FC0F8000007C0F8000007C0F8000007C0F8000007C0FC00000FC07C00000F807F
+00003F803F80007F003FF807FF001FFFFFFE0007FFFFF80003FFFFF00000FFFFC000000F
+FC000023337EA027>I<7FE0000000FFF0000000FFF0000000FFF00000007FF000000003
+F000000003F000000003F000000003F000000003F000000003F000000003F000000003F0
+00000003F000000003F07F000003F1FFC00003F7FFF00003FFFFF00003FFFFF80003FFC1
+F80003FF01FC0003FE00FC0003FC00FC0003F800FC0003F800FC0003F000FC0003F000FC
+0003F000FC0003F000FC0003F000FC0003F000FC0003F000FC0003F000FC0003F000FC00
+03F000FC0003F000FC0003F000FC0003F000FC0003F000FC0003F000FC0003F000FC007F
+FF83FFE0FFFFC7FFF0FFFFC7FFF0FFFFC7FFF07FFF83FFE0242E7FAD27>I<000F000000
+1F8000003FC000003FC000003FC000003FC000001F8000000F0000000000000000000000
+000000000000000000000000000000000000003FFF80007FFFC0007FFFC0007FFFC0003F
+FFC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC00000
+0FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC00000
+0FC000000FC000000FC000000FC000000FC0007FFFFFF0FFFFFFF0FFFFFFF8FFFFFFF07F
+FFFFF01D2F7BAE27>I<00003C00007E0000FF0000FF0000FF0000FF00007E00003C0000
+0000000000000000000000000000000000000001FFFE03FFFF03FFFF03FFFF01FFFF0000
+3F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F0000
+3F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F0000
+3F00003F00003F00003F00003F00003F00003F00003F00003F00003F00007E38007E7C00
+FEFE01FCFE03FCFFFFF8FFFFF07FFFE03FFF8007FE0018407CAE27>I<7FE00000007FF0
+000000FFF00000007FF00000007FF000000001F000000001F000000001F000000001F000
+000001F000000001F000000001F000000001F000000001F000000001F03FFFC001F07FFF
+E001F07FFFE001F07FFFE001F03FFFC001F003F80001F007F00001F00FE00001F01FC000
+01F03F800001F0FF000001F1FE000001F3FC000001F7F8000001FFFC000001FFFE000001
+FFFF000001FF3F000001FE1F800001FC0FC00001F80FE00001F007E00001F003F00001F0
+01F80001F001FC0001F000FE0001F0007E007FFFC1FFF07FFFC3FFF8FFFFE3FFF87FFFC3
+FFF87FFFC3FFF0252E80AD27>I<7FFF8000FFFFC000FFFFC000FFFFC0007FFFC000000F
+C000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000F
+C000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000F
+C000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000F
+C000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC0007FFF
+FFF8FFFFFFFCFFFFFFFCFFFFFFFC7FFFFFF81E2E7CAD27>I<7F07C01F0000FF9FF07FC0
+00FFFFF9FFE000FFFFFFFFF0007FFFFFFFF0000FFC7FF1F8000FF03FC0F8000FE03F80F8
+000FC03F00F8000FC03F00F8000FC03F00F8000F803E00F8000F803E00F8000F803E00F8
+000F803E00F8000F803E00F8000F803E00F8000F803E00F8000F803E00F8000F803E00F8
+000F803E00F8000F803E00F8000F803E00F8000F803E00F8000F803E00F8000F803E00F8
+000F803E00F8007FF0FFC3FF00FFF8FFE3FF80FFF9FFE7FF80FFF8FFE3FF807FF0FFC3FF
+002920819F27>I<7FE07F0000FFF1FFC000FFF7FFF000FFFFFFF0007FFFFFF80003FFC1
+F80003FF01FC0003FE00FC0003FC00FC0003F800FC0003F800FC0003F000FC0003F000FC
+0003F000FC0003F000FC0003F000FC0003F000FC0003F000FC0003F000FC0003F000FC00
+03F000FC0003F000FC0003F000FC0003F000FC0003F000FC0003F000FC0003F000FC007F
+FF83FFE0FFFFC7FFF0FFFFC7FFF0FFFFC7FFF07FFF83FFE024207F9F27>I<001FE00000
+7FF80001FFFE0003FFFF0007FFFF800FF03FC01FC00FE03F8007F03F0003F07F0003F87E
+0001F87E0001F8FC0000FCFC0000FCFC0000FCFC0000FCFC0000FCFC0000FCFC0000FCFE
+0001FC7E0001F87E0001F87F0003F83F8007F03F8007F01FE01FE00FF03FC007FFFF8003
+FFFF0001FFFE00007FF800001FE0001E207C9F27>I<7FE0FF0000FFF3FFC000FFFFFFF0
+00FFFFFFF8007FFFFFFC0003FF81FE0003FE00FF0003FC003F8003F8001F8003F8001FC0
+03F0000FC003F0000FC003F0000FE003F00007E003F00007E003F00007E003F00007E003
+F00007E003F00007E003F0000FE003F0000FC003F8000FC003F8001FC003FC003F8003FC
+007F8003FE00FF0003FF83FE0003FFFFFC0003FFFFF80003FFFFF00003F3FFC00003F0FE
+000003F000000003F000000003F000000003F000000003F000000003F000000003F00000
+0003F000000003F000000003F000000003F000000003F00000007FFF800000FFFFC00000
+FFFFC00000FFFFC000007FFF80000023317F9F27>I<7FFC03FC00FFFE0FFF00FFFE3FFF
+80FFFE7FFFC07FFEFFFFC0007FFE1FC0007FF81FC0007FF00F80007FE00200007FC00000
+007F800000007F800000007F000000007F000000007E000000007E000000007E00000000
+7E000000007E000000007E000000007E000000007E000000007E000000007E000000007E
+000000007E000000007E0000007FFFFF8000FFFFFFC000FFFFFFC000FFFFFFC0007FFFFF
+800022207E9F27>114 D<00FFF38007FFFFC01FFFFFC03FFFFFC07FFFFFC07F803FC0FC
+000FC0F8000FC0F8000FC0F8000780FC0000007F8000007FFC00003FFFF0001FFFFC0007
+FFFF0001FFFF80000FFFC000003FE0000007E0780003F0FC0001F0FC0001F0FE0001F0FE
+0003F0FF0007E0FFE01FE0FFFFFFC0FFFFFF80FFFFFF00FBFFFC00707FF0001C207B9F27
+>I<003C0000007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E
+00007FFFFFF0FFFFFFF8FFFFFFF8FFFFFFF87FFFFFF0007E0000007E0000007E0000007E
+0000007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E
+0000007E0000007E0018007E007E007E007E007E007E007E007E007E00FE003F00FC003F
+83FC003FFFF8001FFFF0000FFFE00003FFC00000FF001F297EA827>I<7FE01FF800FFF0
+3FFC00FFF03FFC00FFF03FFC007FF01FFC0003F000FC0003F000FC0003F000FC0003F000
+FC0003F000FC0003F000FC0003F000FC0003F000FC0003F000FC0003F000FC0003F000FC
+0003F000FC0003F000FC0003F000FC0003F000FC0003F000FC0003F000FC0003F000FC00
+03F001FC0003F001FC0003F003FC0003FC0FFC0001FFFFFFE001FFFFFFF000FFFFFFF000
+3FFEFFF0000FF87FE024207F9F27>I<7FFC0FFF80FFFE1FFFC0FFFE1FFFC0FFFE1FFFC0
+7FFC0FFF8007E000F80003E001F80003E001F00003F001F00001F003F00001F803E00000
+F803E00000F803E00000FC07C000007C07C000007C07C000007E0F8000003E0F8000003E
+0F8000001F0F0000001F1F0000001F1F0000000F1F0000000F9E0000000FBE00000007BE
+00000007FC00000003FC00000003FC00000003F800000001F800000001F800000001F000
+000001F000000003F000000003E000000003E000000007E000000007C000000807C00000
+3E0FC000007F0F8000007F1F8000007E7F0000007FFE0000003FFC0000003FF80000001F
+F000000007C000000022317E9F27>121 D E /Fo 24 122 df<1E007F80FF80FFC0FFC0
+FFE0FFE0FFE07FE01E60006000600060006000E000C000C000C001C00180038003000700
+06000E001C003800700060000B1D78891B>44 D<000030000000F0000001F0000003F000
+001FF00000FFF000FFFFF000FFE7F000FF07F0000007F0000007F0000007F0000007F000
+0007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F000
+0007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F000
+0007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F000
+0007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F000
+0007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F0000007F000
+0007F0000007F0000007F000000FF800001FFC007FFFFFFF7FFFFFFF7FFFFFFF204278C1
+31>49 D<0003FE0000001FFFC000007FFFF00001F80FFC0003C001FE00078000FF000E00
+007F801C00003FC01C00001FE03800001FF03000000FF07000000FF860000007F86C0000
+07F8FF000007FCFF800007FCFFC00007FCFFC00003FCFFC00003FCFFC00003FCFFC00003
+FC7F800007FC3F000007FC00000007FC00000007F800000007F80000000FF80000000FF0
+0000001FF00000001FE00000001FE00000003FC00000007F800000007F00000000FF0000
+0000FE00000001FC00000003F800000007F000000007E00000000FC00000001F80000000
+3F000000007C00000000F800000000F000000001E000000003C000000007800000000F00
+000C001E00000C003C00000C0038000018007000001800E000001801C000001803800000
+3807000000300E000000701FFFFFFFF01FFFFFFFF03FFFFFFFF07FFFFFFFF0FFFFFFFFE0
+FFFFFFFFE0FFFFFFFFE026427BC131>I<0001FF0000000FFFE000003FFFFC0000FE01FE
+0001F0007F8003C0003FC00700001FE00E00001FE00E00000FF00FE0000FF01FF0000FF8
+1FF0000FF81FF00007F81FF80007F81FF00007F81FF00007F80FE0000FF803C0000FF800
+00000FF00000000FF00000000FF00000001FE00000001FE00000003FC00000003F800000
+007F00000000FE00000001FC00000003F00000001FC000000FFF0000000FFFF000000001
+FC000000007F000000003F800000001FC00000000FE00000000FF000000007F800000007
+FC00000003FC00000003FE00000003FE00000001FE00000001FF00000001FF00000001FF
+1E000001FF7F800001FFFFC00001FFFFC00001FFFFC00001FFFFC00001FFFFC00001FEFF
+800003FEFF800003FE7E000003FC70000007FC30000007F83800000FF81C00000FF00E00
+001FE00780003FC003E0007F8001FE01FE00007FFFF800000FFFE0000001FF000028447C
+C131>I<0000FF00000007FFE000001FFFF800007F80FC0000FC007E0001F8003F0003F0
+001F8007E0000FC00FE00007E01FC00007E01FC00003F03F800003F03F800003F87F8000
+01F87F000001FC7F000001FCFF000001FCFF000001FCFF000001FEFF000000FEFF000000
+FEFF000000FEFF000000FEFF000000FEFF000000FFFF000000FFFF000000FFFF000000FF
+7F000001FF7F000001FF7F000001FF3F800001FF3F800003FF1F800003FF1FC00003FF0F
+C00007FF07E00006FF07E0000EFF03F0001CFF01F80038FF007C0070FF003F01E0FF000F
+FF80FE0001FE00FE00000000FE00000001FE00000001FC00000001FC00000001FC000000
+01FC00000003F800000003F800000003F00F800007F01FC00007E03FE0000FE03FE0000F
+C03FE0001F803FE0001F803FC0003F003F80007E001E0000FC001C0001F8000F0003F000
+07E01FE00003FFFF800000FFFE0000001FF0000028447CC131>57
+D<FFFFFFFFFFFFF0FFFFFFFFFFFFF0FFFFFFFFFFFFF001FFC000007FF0007F8000000FF8
+007F80000003F8007F80000001F8007F80000000F8007F8000000078007F800000003800
+7F8000000038007F800000001C007F800000001C007F800000001C007F800000000C007F
+800000000C007F800000000C007F800000000C007F800000000E007F8000000006007F80
+000C0006007F80000C0006007F80000C0000007F80000C0000007F80000C0000007F8000
+0C0000007F80000C0000007F80001C0000007F80001C0000007F80003C0000007F80007C
+0000007F8001FC0000007FFFFFFC0000007FFFFFFC0000007FFFFFFC0000007F8001FC00
+00007F80007C0000007F80003C0000007F80001C0000007F80001C0000007F80000C0000
+007F80000C0000007F80000C0000007F80000C0000007F80000C0000007F80000C000000
+7F80000C0000007F8000000000007F8000000000007F8000000000007F8000000000007F
+8000000000007F8000000000007F8000000000007F8000000000007F8000000000007F80
+00000000007F8000000000007F8000000000007F8000000000007F8000000000007F8000
+000000007F8000000000007FC00000000001FFE000000000FFFFFFF8000000FFFFFFF800
+0000FFFFFFF800000037447CC340>70 D<FFFFFFC00001FFFFC0FFFFFFC00001FFFFC0FF
+FFFFC00001FFFFC001FFE00000007FFC0000FFC00000003FE000007F800000003F800000
+7F800000003E0000007F800000003C0000007F80000000380000007F8000000070000000
+7F80000000E00000007F80000001C00000007F80000003800000007F8000000700000000
+7F8000001E000000007F80000038000000007F80000070000000007F800000E000000000
+7F800001C0000000007F80000380000000007F80000700000000007F80000E0000000000
+7F80001C00000000007F80003800000000007F80007000000000007F8000E00000000000
+7F8001C000000000007F8003E000000000007F8007F000000000007F800FF00000000000
+7F801FF800000000007F803FFC00000000007F8077FC00000000007F80E3FE0000000000
+7F81C1FF00000000007F8381FF00000000007F8700FF80000000007F8E007FC000000000
+7F9C007FC0000000007FB8003FE0000000007FF0001FF0000000007FC0001FF000000000
+7F80000FF8000000007F800007FC000000007F800007FC000000007F800003FE00000000
+7F800001FF000000007F800001FF000000007F800000FF800000007F8000007FC0000000
+7F8000007FC00000007F8000003FE00000007F8000001FF00000007F8000001FF0000000
+7F8000000FF80000007F80000007FC0000007F80000007FC0000007F80000003FE000000
+7F80000001FF0000007F80000001FF0000007F80000000FF8000007F80000000FFC00000
+7F80000000FFE00000FFC0000000FFF00001FFE0000001FFFC00FFFFFFC0001FFFFFE0FF
+FFFFC0001FFFFFE0FFFFFFC0001FFFFFE043447CC34C>75 D<FFFF800000000007FFFCFF
+FFC0000000000FFFFCFFFFC0000000000FFFFC01FFC0000000000FFE00006FE000000000
+1BF800006FE0000000001BF800006FE0000000001BF8000067F00000000033F8000067F0
+0000000033F8000063F80000000063F8000063F80000000063F8000063F80000000063F8
+000061FC00000000C3F8000061FC00000000C3F8000061FC00000000C3F8000060FE0000
+000183F8000060FE0000000183F80000607F0000000303F80000607F0000000303F80000
+607F0000000303F80000603F8000000603F80000603F8000000603F80000603F80000006
+03F80000601FC000000C03F80000601FC000000C03F80000600FE000001803F80000600F
+E000001803F80000600FE000001803F800006007F000003003F800006007F000003003F8
+00006007F000003003F800006003F800006003F800006003F800006003F800006001FC00
+00C003F800006001FC0000C003F800006001FC0000C003F800006000FE00018003F80000
+6000FE00018003F800006000FE00018003F8000060007F00030003F8000060007F000300
+03F8000060003F80060003F8000060003F80060003F8000060003F80060003F800006000
+1FC00C0003F8000060001FC00C0003F8000060001FC00C0003F8000060000FE0180003F8
+000060000FE0180003F80000600007F0300003F80000600007F0300003F80000600007F0
+300003F80000600003F8600003F80000600003F8600003F80000600003F8600003F80000
+600001FCC00003F80000600001FCC00003F80000600000FF800003F80000600000FF8000
+03F80000600000FF800003F800006000007F000003F80000F000007F000003F80000F000
+007F000003F80001F800003E000003F8000FFF00003E00000FFE00FFFFF0001C0007FFFF
+FCFFFFF0001C0007FFFFFCFFFFF0001C0007FFFFFC4E447BC359>77
+D<FFFFFFFFE000000000FFFFFFFFFF00000000FFFFFFFFFFC000000001FFC0003FF80000
+00007F800003FC000000007F800000FF000000007F8000007F800000007F8000003FC000
+00007F8000001FE00000007F8000000FF00000007F80000007F80000007F80000007F800
+00007F80000007FC0000007F80000003FC0000007F80000003FE0000007F80000003FE00
+00007F80000003FE0000007F80000003FE0000007F80000003FE0000007F80000003FE00
+00007F80000003FE0000007F80000003FC0000007F80000003FC0000007F80000007FC00
+00007F80000007F80000007F8000000FF00000007F8000000FF00000007F8000001FE000
+00007F8000003FC00000007F8000007F000000007F800001FE000000007F800007F80000
+00007F80003FE0000000007FFFFFFF00000000007FFFFFFC00000000007F80007F800000
+00007F80000FE0000000007F800007F0000000007F800003FC000000007F800001FE0000
+00007F800000FE000000007F800000FF000000007F8000007F800000007F8000007F8000
+00007F8000003FC00000007F8000003FC00000007F8000003FC00000007F8000003FC000
+00007F8000003FC00000007F8000003FC00000007F8000003FC00000007F8000003FE000
+00007F8000003FE00000007F8000003FE00000007F8000003FE00000007F8000003FE000
+00007F8000003FE00000007F8000003FE00000007F8000003FE00060007F8000003FF000
+60007F8000001FF00060007F8000001FF00060007F8000001FF000E0007F8000000FF800
+C001FFE0000007F801C0FFFFFFC00007F80180FFFFFFC00001FC0380FFFFFFC00000FE07
+000000000000003FFE0000000000000007F80043467CC348>82 D<0001FF000300000FFF
+E00700003FFFF8070000FE00FE0F0001F8001F0F0007E000079F0007C00003DF000F8000
+01FF001F000000FF003F0000007F003E0000003F007E0000003F007E0000001F007C0000
+001F00FC0000000F00FC0000000F00FC0000000700FC0000000700FC0000000700FE0000
+000700FE0000000300FE0000000300FF0000000300FF00000003007F80000000007FC000
+0000007FE0000000003FF8000000003FFE000000001FFFE00000000FFFFE00000007FFFF
+E0000003FFFFFC000001FFFFFF000000FFFFFFC000003FFFFFF000000FFFFFF8000001FF
+FFFC0000001FFFFE00000001FFFE000000001FFF0000000003FF8000000001FF80000000
+00FFC0000000007FC0000000003FC0000000001FC0000000001FE0C00000000FE0C00000
+000FE0C00000000FE0C000000007E0C000000007E0C000000007E0E000000007E0E00000
+0007E0E000000007E0F000000007C0F00000000FC0F80000000FC0F80000000F80FC0000
+001F80FE0000001F00FF0000003F00FF8000007E00FBC00000FC00F9F00001F800F07C00
+03F000F03FC00FE000E00FFFFF8000E001FFFE0000C0003FF000002B487BC536>I<0007
+FC000000003FFF80000000F80FE0000003C003F00000070001F800000E0000FC00000FC0
+007E00001FE0007F00001FF0003F80001FF0003F80001FF0003F80001FF0001FC0001FF0
+001FC0000FE0001FC0000380001FC0000000001FC0000000001FC0000000001FC0000000
+001FC00000000FFFC0000001FFFFC000000FFE1FC000003FC01FC00000FF001FC00003FC
+001FC00007F8001FC0000FF0001FC0001FE0001FC0003FC0001FC0007FC0001FC0007F80
+001FC0007F80001FC060FF00001FC060FF00001FC060FF00001FC060FF00003FC060FF00
+003FC060FF00003FC060FF80007FC0607F8000EFC0607FC000C7E0C03FC001C7E0C01FE0
+0783F1C007F81E03FF8001FFFC01FF00001FE0007C002B2E7CAC31>97
+D<01FC00000000FFFC00000000FFFC00000000FFFC0000000007FC0000000003FC000000
+0001FC0000000001FC0000000001FC0000000001FC0000000001FC0000000001FC000000
+0001FC0000000001FC0000000001FC0000000001FC0000000001FC0000000001FC000000
+0001FC0000000001FC0000000001FC0000000001FC0000000001FC0000000001FC000000
+0001FC0000000001FC03FC000001FC0FFF800001FC3C07E00001FC7001F80001FDE0007E
+0001FD80003F0001FF80001F8001FF00001FC001FE00000FE001FC000007E001FC000007
+F001FC000007F001FC000003F801FC000003F801FC000003FC01FC000003FC01FC000001
+FC01FC000001FE01FC000001FE01FC000001FE01FC000001FE01FC000001FE01FC000001
+FE01FC000001FE01FC000001FE01FC000001FE01FC000001FE01FC000001FE01FC000001
+FC01FC000003FC01FC000003FC01FC000003F801FC000003F801FC000007F001FC000007
+F001FE00000FE001FE00000FC001FF00001FC001FB00003F8001F380007E0001E1C000FC
+0001E0F001F80001C03C07E00001801FFF8000000003FC00002F467DC436>I<00007F80
+000003FFF000000FC07C00003F000F0000FC00038001F80001C003F8000FC007F0001FE0
+07E0003FE00FE0003FE01FC0003FE01FC0003FE03F80003FE03F80001FC07F800007007F
+800000007F800000007F00000000FF00000000FF00000000FF00000000FF00000000FF00
+000000FF00000000FF00000000FF00000000FF00000000FF00000000FF000000007F0000
+00007F800000007F800000003F800000003F800000303FC00000301FC00000700FE00000
+600FE00000E007F00000C003F80001C001F800038000FC000700003F001E00001FC07800
+0007FFF0000000FF8000242E7DAC2B>I<000000007F000000003FFF000000003FFF0000
+00003FFF0000000001FF0000000000FF00000000007F00000000007F00000000007F0000
+0000007F00000000007F00000000007F00000000007F00000000007F00000000007F0000
+0000007F00000000007F00000000007F00000000007F00000000007F00000000007F0000
+0000007F00000000007F00000000007F00000000007F0000007F807F000003FFF07F0000
+0FC07C7F00003F000E7F00007E00077F0000FC0003FF0003F80001FF0007F00000FF0007
+E00000FF000FE000007F001FC000007F001FC000007F003F8000007F003F8000007F007F
+8000007F007F8000007F007F0000007F00FF0000007F00FF0000007F00FF0000007F00FF
+0000007F00FF0000007F00FF0000007F00FF0000007F00FF0000007F00FF0000007F00FF
+0000007F00FF0000007F007F0000007F007F8000007F007F8000007F003F8000007F003F
+8000007F001FC000007F001FC000007F000FC00000FF000FE00000FF0007F00001FF0003
+F00003FF0001F800077F8000FC000E7FC0003F001C7FFE000FC0F87FFE0003FFE07FFE00
+007F007F002F467DC436>I<0001FE00000007FFC000001F03F000007E00FC0000FC007E
+0001F8003F0003F0003F0007E0001F800FE0001FC00FC0000FC01FC0000FC03F80000FE0
+3F800007E03F800007E07F800007F07F000007F07F000007F0FF000007F0FF000007F0FF
+000007F0FFFFFFFFF0FFFFFFFFF0FF00000000FF00000000FF00000000FF00000000FF00
+000000FF000000007F000000007F000000007F800000007F800000003F800000003F8000
+00301FC00000301FC00000700FC00000600FE00000E007F00000C003F00001C001F80003
+8000FC000700003E001E00001F80F8000003FFE0000000FF0000242E7DAC2B>I<01FC00
+000000FFFC00000000FFFC00000000FFFC0000000007FC0000000003FC0000000001FC00
+00000001FC0000000001FC0000000001FC0000000001FC0000000001FC0000000001FC00
+00000001FC0000000001FC0000000001FC0000000001FC0000000001FC0000000001FC00
+00000001FC0000000001FC0000000001FC0000000001FC0000000001FC0000000001FC00
+00000001FC01FE000001FC07FFC00001FC1E07F00001FC3801F80001FC7001FC0001FCE0
+00FC0001FDC000FE0001FD8000FE0001FF80007F0001FF00007F0001FF00007F0001FE00
+007F0001FE00007F0001FE00007F0001FC00007F0001FC00007F0001FC00007F0001FC00
+007F0001FC00007F0001FC00007F0001FC00007F0001FC00007F0001FC00007F0001FC00
+007F0001FC00007F0001FC00007F0001FC00007F0001FC00007F0001FC00007F0001FC00
+007F0001FC00007F0001FC00007F0001FC00007F0001FC00007F0001FC00007F0001FC00
+007F0001FC00007F0001FC00007F0001FC00007F0001FC00007F0003FE0000FF80FFFFF8
+3FFFFEFFFFF83FFFFEFFFFF83FFFFE2F457DC436>104 D<01E00007F80007F8000FFC00
+0FFC000FFC000FFC0007F80007F80001E000000000000000000000000000000000000000
+00000000000000000000000000000000000000000001FC00FFFC00FFFC00FFFC0007FC00
+03FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC00
+01FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC00
+01FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0003FE00
+FFFFF8FFFFF8FFFFF815437DC21C>I<01FC00000000FFFC00000000FFFC00000000FFFC
+0000000007FC0000000003FC0000000001FC0000000001FC0000000001FC0000000001FC
+0000000001FC0000000001FC0000000001FC0000000001FC0000000001FC0000000001FC
+0000000001FC0000000001FC0000000001FC0000000001FC0000000001FC0000000001FC
+0000000001FC0000000001FC0000000001FC0000000001FC0000000001FC001FFFE001FC
+001FFFE001FC001FFFE001FC000FFF0001FC0007F80001FC0007E00001FC0007C00001FC
+0007800001FC000E000001FC001C000001FC0038000001FC0070000001FC00E0000001FC
+01C0000001FC0380000001FC0700000001FC0F00000001FC3F80000001FC7FC0000001FC
+FFC0000001FDCFE0000001FF8FF0000001FF07F0000001FE03F8000001FC03FC000001FC
+01FC000001FC00FE000001FC00FF000001FC007F000001FC003F800001FC003FC00001FC
+001FC00001FC000FE00001FC000FF00001FC0007F00001FC0007F80001FC0003FC0001FC
+0003FE0001FC0003FF0003FE0007FF80FFFFF81FFFF8FFFFF81FFFF8FFFFF81FFFF82D45
+7DC433>107 D<01FC00FFFC00FFFC00FFFC0007FC0003FC0001FC0001FC0001FC0001FC
+0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC
+0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC
+0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC
+0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC
+0001FC0001FC0001FC0001FC0001FC0001FC0001FC0003FE00FFFFF8FFFFF8FFFFF81545
+7DC41C>I<01FC03FC0000FFFC0FFF8000FFFC3C07E000FFFC7001F80007FDE000FE0001
+FD80007F0001FF80003F8001FF00001FC001FE00001FE001FC00000FE001FC00000FF001
+FC000007F001FC000007F801FC000003F801FC000003FC01FC000003FC01FC000003FC01
+FC000001FE01FC000001FE01FC000001FE01FC000001FE01FC000001FE01FC000001FE01
+FC000001FE01FC000001FE01FC000001FE01FC000001FE01FC000001FE01FC000003FC01
+FC000003FC01FC000003FC01FC000007F801FC000007F801FC000007F001FC00000FF001
+FE00000FE001FE00001FC001FF00003FC001FF00003F8001FF80007E0001FDC000FC0001
+FCF003F80001FC3C0FE00001FC1FFF800001FC03FC000001FC0000000001FC0000000001
+FC0000000001FC0000000001FC0000000001FC0000000001FC0000000001FC0000000001
+FC0000000001FC0000000001FC0000000001FC0000000001FC0000000001FC0000000003
+FE00000000FFFFF8000000FFFFF8000000FFFFF80000002F3F7DAB36>112
+D<03F803F0FFF81FFCFFF83C3EFFF8707F07F8E0FF03F9C0FF01F980FF01FB80FF01FB00
+7E01FB003C01FF000001FE000001FE000001FE000001FE000001FC000001FC000001FC00
+0001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC00
+0001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC00
+0001FC000001FC000001FC000001FC000003FF0000FFFFFE00FFFFFE00FFFFFE00202C7D
+AB26>114 D<003FE01801FFFC3807E01F780F0003F81E0001F83C0000F87C0000787800
+0078F8000038F8000038F8000018F8000018FC000018FC000018FE000018FF8000007FC0
+00007FFC00003FFFE0001FFFFC000FFFFF0007FFFFC003FFFFE000FFFFF0001FFFF80000
+FFF800000FFC000003FCC00001FEC00000FEC000007EE000007EE000003EE000003EF000
+003EF000003EF000003EF800003CFC00007CFC000078FE0000F8FF0001F0F38003E0F1F0
+0F80E07FFE00C00FF0001F2E7DAC26>I<01FC00007F00FFFC003FFF00FFFC003FFF00FF
+FC003FFF0007FC0001FF0003FC0000FF0001FC00007F0001FC00007F0001FC00007F0001
+FC00007F0001FC00007F0001FC00007F0001FC00007F0001FC00007F0001FC00007F0001
+FC00007F0001FC00007F0001FC00007F0001FC00007F0001FC00007F0001FC00007F0001
+FC00007F0001FC00007F0001FC00007F0001FC00007F0001FC00007F0001FC00007F0001
+FC00007F0001FC00007F0001FC00007F0001FC00007F0001FC00007F0001FC0000FF0001
+FC0000FF0001FC0000FF0001FC0001FF0001FC0001FF0000FC0001FF0000FE0003FF0000
+7E00077F80007F000E7FC0003F001C7FFE000FC0787FFE0003FFF07FFE00007F807F002F
+2D7DAB36>117 D<FFFFF001FFFCFFFFF001FFFCFFFFF001FFFC07FF00007FE003FE0000
+1F8001FE00001F0001FE00000E0000FE00000C0000FF00001C00007F00001800007F0000
+1800007F80003800003F80003000003F80003000001FC0006000001FC0006000001FE000
+E000000FE000C000000FE000C0000007F00180000007F00180000007F80380000003F803
+00000003F80300000001FC0600000001FC0600000001FE0E00000000FE0C00000000FE0C
+000000007F18000000007F18000000007FB8000000003FB0000000003FB0000000001FE0
+000000001FE0000000001FE0000000000FC0000000000FC0000000000780000000000780
+000000000780000000000300000000000300000000000600000000000600000000000600
+000000000C00000000000C0000000000180000000000180000003C00180000007E003000
+0000FF0030000000FF0060000000FF0060000000FF00C0000000FE01C00000007C038000
+00007007000000003C1E000000000FFC0000000003F0000000002E3F7EAA33>121
+D E /Fp 17 120 df<000000000078000000000000007800000000000000F80000000000
+0001F800000000000001F800000000000003F800000000000007F800000000000007F800
+00000000000FF80000000000001FF80000000000001FF80000000000003FF80000000000
+003FF80000000000007FF8000000000000FFF8000000000000EFF8000000000001EFF800
+0000000003CFF80000000000038FF80000000000078FF80000000000070FF80000000000
+0E0FF800000000001E0FF800000000001C0FF800000000003C0FF80000000000780FF800
+00000000700FF80000000000F00FF80000000000E00FF80000000001C00FF80000000003
+C00FF80000000003800FF80000000007800FF8000000000F000FF8000000000E000FF800
+0000001E000FF8000000001C000FF80000000038000FF80000000078000FF80000000070
+000FF800000000F0000FF800000001E0000FF800000001C0000FF800000003C0000FF800
+00000380000FF80000000700000FF80000000F00000FF80000000E00000FF80000001E00
+000FF80000003C00000FF80000003800000FF80000007800000FF8000000F000000FF800
+0000E000000FF8000001E000000FF8000001C000000FF8000003C000000FF80000078000
+000FF80000070000000FF800000F0000000FF800001E0000000FF800001C0000000FF800
+003C0000000FF80000380000000FF80000700000000FF80000F00000000FF80000FFFFFF
+FFFFFFFFE0FFFFFFFFFFFFFFE0FFFFFFFFFFFFFFE0FFFFFFFFFFFFFFE0000000000FF800
+00000000000FF80000000000000FF80000000000000FF80000000000000FF80000000000
+000FF80000000000000FF80000000000000FF80000000000000FF80000000000000FF800
+00000000000FF80000000000000FF80000000000000FF80000000000000FF80000000000
+000FF80000000000000FF80000000000000FF80000000000000FF80000000000000FF800
+00000000001FFC0000000000007FFF0000000001FFFFFFFFC0000001FFFFFFFFC0000001
+FFFFFFFFC0000001FFFFFFFFC03B5F7DDE42>52 D<000003FF80000000001FFFF8000000
+00FFFFFE00000003FFFFFF80000007FE00FFE000001FE0001FF000003F800007FC00007E
+000001FE0000FC000000FF0001F80000007F0001F00000003F8003E00000001FC007E000
+00000FC007C00000000FE00FC000000007E00FC000000007E00F8000000007F01F800000
+0003F01F8000000003F01F8000000003F01F8000000003F01F8000000003F01FC0000000
+03F01FC000000003F01FE000000007F01FE000000007E01FF000000007E00FF80000000F
+E00FFC0000000FC00FFE0000000FC007FF0000001F8007FFC000003F8003FFE000003F00
+03FFF800007E0001FFFC0000FC0000FFFE0001F80000FFFF8003F000007FFFC00FE00000
+3FFFF01F8000000FFFF83F00000007FFFEFC00000001FFFFF000000000FFFFE000000000
+3FFFE0000000001FFFF8000000000FFFFC000000001FFFFE000000007FFFFF80000001F8
+7FFFC0000003F03FFFF000000FC00FFFF800001F8007FFFC00003F0001FFFF00007E0000
+FFFF8000FC00003FFF8001F800001FFFC003F000000FFFE007E0000003FFF00FC0000001
+FFF00FC00000007FF81F800000003FF83F800000001FF83F000000000FFC7F0000000007
+FC7E0000000003FC7E0000000003FE7E0000000001FEFE0000000000FEFC0000000000FE
+FC0000000000FEFC00000000007EFC00000000007EFC00000000007EFC00000000007EFC
+00000000007EFC00000000007EFE00000000007C7E0000000000FC7E0000000000FC7F00
+00000000F83F0000000001F83F8000000001F01F8000000003F01FC000000003E00FE000
+000007E007F00000000FC007F80000001F8003FC0000003F0001FE000000FE00007F8000
+01FC00003FE0000FF000000FFE007FE0000007FFFFFF80000001FFFFFE000000003FFFF8
+0000000003FF80000037607BDD42>56 D<00000000007FF800000060000000000FFFFF80
+0000E0000000007FFFFFE00000E000000003FFFFFFFC0001E00000000FFFE003FE0001E0
+0000003FFE00003F8003E0000000FFF0000007C003E0000001FFC0000003F007E0000007
+FF00000000F80FE000000FFC000000007C0FE000001FF8000000001E1FE000007FE00000
+00000F1FE00000FFC00000000007BFE00001FF800000000003FFE00003FF000000000003
+FFE00007FE000000000001FFE0000FFC000000000000FFE0000FF80000000000007FE000
+1FF00000000000007FE0003FF00000000000003FE0007FE00000000000001FE0007FC000
+00000000001FE000FFC00000000000000FE001FF800000000000000FE001FF8000000000
+00000FE003FF0000000000000007E003FF0000000000000007E007FE0000000000000003
+E007FE0000000000000003E00FFC0000000000000003E00FFC0000000000000001E01FFC
+0000000000000001E01FFC0000000000000001E01FF80000000000000001E03FF8000000
+0000000001E03FF80000000000000000E03FF00000000000000000E03FF0000000000000
+0000E07FF00000000000000000E07FF00000000000000000007FF0000000000000000000
+7FF00000000000000000007FF0000000000000000000FFE0000000000000000000FFE000
+0000000000000000FFE0000000000000000000FFE0000000000000000000FFE000000000
+0000000000FFE0000000000000000000FFE0000000000000000000FFE000000000000000
+0000FFE0000000000000000000FFE0000000000000000000FFE0000000000000000000FF
+E0000000000000000000FFE0000000000000000000FFE0000000000000000000FFE00000
+00000000000000FFE00000000000000000007FF00000000000000000007FF00000000000
+000000007FF00000000000000000007FF00000000000000000007FF00000000000000000
+003FF00000000000000000003FF00000000000000000E03FF80000000000000000E03FF8
+0000000000000000E01FF80000000000000000E01FFC0000000000000000E01FFC000000
+0000000000E00FFC0000000000000001E00FFC0000000000000001C007FE000000000000
+0001C007FE0000000000000001C003FF0000000000000001C003FF0000000000000003C0
+01FF80000000000000038001FF80000000000000078000FFC00000000000000780007FC0
+0000000000000700007FE00000000000000F00003FF00000000000001E00001FF0000000
+0000001E00000FF80000000000003C00000FFC00000000000038000007FE000000000000
+78000003FF000000000000F0000001FF800000000001E0000000FFC00000000003C00000
+007FE00000000007C00000001FF8000000000F800000000FFC000000001F0000000007FF
+000000007C0000000001FFC0000001F80000000000FFF0000007F000000000003FFE0000
+1FC000000000000FFFE001FF00000000000003FFFFFFFC000000000000007FFFFFF00000
+00000000000FFFFF8000000000000000007FF80000000053667AE360>67
+D<000007FF0000030000003FFFF00007000001FFFFFC0007000007FFFFFF000F00000FFC
+00FFC00F00003FE0000FF01F00007F800003F81F0000FE000000FC3F0001FC0000007E3F
+0003F80000001F7F0007F00000000FFF000FE000000007FF000FC000000007FF001FC000
+000003FF001F8000000001FF003F8000000000FF003F0000000000FF007F00000000007F
+007F00000000007F007E00000000003F007E00000000003F00FE00000000003F00FE0000
+0000001F00FE00000000001F00FE00000000001F00FE00000000000F00FE00000000000F
+00FF00000000000F00FF00000000000F00FF00000000000F00FF80000000000700FF8000
+00000007007FC00000000007007FC00000000007007FE00000000000003FF00000000000
+003FF80000000000003FFC0000000000001FFE0000000000001FFF8000000000000FFFE0
+000000000007FFFC000000000007FFFFC00000000003FFFFF80000000001FFFFFF800000
+0000FFFFFFF8000000007FFFFFFF800000001FFFFFFFE00000000FFFFFFFF800000003FF
+FFFFFE00000000FFFFFFFF800000001FFFFFFFC000000001FFFFFFE0000000003FFFFFF0
+0000000003FFFFF800000000003FFFFC000000000003FFFE0000000000007FFE00000000
+00001FFF0000000000000FFF80000000000003FF80000000000001FFC0000000000000FF
+C0000000000000FFC00000000000007FE00000000000003FE00000000000003FE0000000
+0000001FE0E000000000001FF0E000000000000FF0E000000000000FF0E000000000000F
+F0E000000000000FF0E0000000000007F0E0000000000007F0F0000000000007F0F00000
+00000007F0F0000000000007F0F0000000000007F0F8000000000007F0F8000000000007
+E0F800000000000FE0FC00000000000FE0FC00000000000FC0FE00000000000FC0FF0000
+0000001FC0FF00000000001F80FF80000000003F80FFC0000000003F00FFE0000000007F
+00FFF000000000FE00FEF800000000FC00FEFC00000001F800FC7F00000003F800FC1F80
+00000FF000F80FE000001FE000F807FC00007F8000F001FFE003FF0000F0007FFFFFFC00
+00E0001FFFFFF00000E00003FFFFC00000C000001FFE0000003C667AE349>83
+D<FFFFFFFF0000001FFFFFF0FFFFFFFF0000001FFFFFF0FFFFFFFF0000001FFFFFF0FFFF
+FFFF0000001FFFFFF000FFFF0000000000FFFE00003FFC00000000003FF800001FF80000
+0000000FE000001FF800000000000FE000001FF8000000000007C000001FF80000000000
+07C000001FF80000000000038000001FF80000000000038000001FF80000000000038000
+001FF80000000000038000001FF80000000000038000001FF80000000000038000001FF8
+0000000000038000001FF80000000000038000001FF80000000000038000001FF8000000
+0000038000001FF80000000000038000001FF80000000000038000001FF8000000000003
+8000001FF80000000000038000001FF80000000000038000001FF8000000000003800000
+1FF80000000000038000001FF80000000000038000001FF80000000000038000001FF800
+00000000038000001FF80000000000038000001FF80000000000038000001FF800000000
+00038000001FF80000000000038000001FF80000000000038000001FF800000000000380
+00001FF80000000000038000001FF80000000000038000001FF80000000000038000001F
+F80000000000038000001FF80000000000038000001FF80000000000038000001FF80000
+000000038000001FF80000000000038000001FF80000000000038000001FF80000000000
+038000001FF80000000000038000001FF80000000000038000001FF80000000000038000
+001FF80000000000038000001FF80000000000038000001FF80000000000038000001FF8
+0000000000038000001FF80000000000038000001FF80000000000038000001FF8000000
+0000038000001FF80000000000038000001FF80000000000038000001FF8000000000003
+8000001FF80000000000038000001FF80000000000038000001FF8000000000003800000
+1FF80000000000038000001FF80000000000038000001FF80000000000038000001FF800
+00000000038000001FF80000000000038000001FF80000000000038000001FF800000000
+00038000001FF80000000000038000001FF80000000000038000001FF800000000000780
+00000FF80000000000070000000FFC0000000000070000000FFC0000000000070000000F
+FC00000000000700000007FC00000000000F00000007FC00000000000E00000007FE0000
+0000001E00000003FE00000000001E00000003FE00000000001C00000001FF0000000000
+3C00000001FF00000000003800000000FF80000000007800000000FF8000000000F00000
+00007FC000000000F0000000003FC000000001E0000000003FE000000003C0000000001F
+F000000007C0000000000FF80000000F800000000007FC0000001F000000000003FE0000
+003E000000000001FF000000FC0000000000007FC00001F80000000000003FF0000FF000
+00000000000FFE007FC000000000000003FFFFFF0000000000000000FFFFFC0000000000
+0000003FFFF0000000000000000003FF8000000000546479E163>85
+D<000001FF80000000000FFFF8000000003FFFFE00000000FF007F80000003FC0007E000
+0007F00001F000001FE000007800003FC000003C00007F8000001E0000FF0000000F0001
+FE0000001F0001FC000000FF0003FC000001FF8007F8000003FF8007F8000003FF800FF0
+000003FF800FF0000003FF801FE0000003FF801FE0000003FF803FE0000001FF003FC000
+00007C003FC000000000007FC000000000007FC000000000007FC000000000007F800000
+000000FF800000000000FF800000000000FF800000000000FF800000000000FF80000000
+0000FF800000000000FF800000000000FF800000000000FF800000000000FF8000000000
+00FF800000000000FF800000000000FF8000000000007F8000000000007FC00000000000
+7FC000000000007FC000000000007FC000000000003FC000000000003FE000000000003F
+E000000000001FE000000001C01FF000000001C00FF000000003C00FF8000000038007F8
+000000038003FC000000078003FE000000070001FE0000000F0000FF0000001E00007F80
+00003C00003FC000007800001FE00000F000000FF80001E0000003FC0007C0000000FF80
+3F800000003FFFFE000000000FFFF80000000001FF80000032417CBF3A>99
+D<0000000000001E000000000000003FFE00000000000007FFFE00000000000007FFFE00
+000000000007FFFE00000000000007FFFE000000000000000FFE0000000000000003FE00
+00000000000003FE0000000000000001FE0000000000000001FE0000000000000001FE00
+00000000000001FE0000000000000001FE0000000000000001FE0000000000000001FE00
+00000000000001FE0000000000000001FE0000000000000001FE0000000000000001FE00
+00000000000001FE0000000000000001FE0000000000000001FE0000000000000001FE00
+00000000000001FE0000000000000001FE0000000000000001FE0000000000000001FE00
+00000000000001FE0000000000000001FE0000000000000001FE0000000000000001FE00
+00000000000001FE0000000000000001FE0000000000000001FE0000000000000001FE00
+00000000000001FE0000000000FF8001FE000000000FFFF801FE000000003FFFFE01FE00
+000000FF803F81FE00000003FC0007C1FE00000007F80001E1FE0000001FE00000F9FE00
+00003FC000007DFE0000007F8000003DFE000000FF0000001FFE000001FE0000000FFE00
+0001FC00000007FE000003FC00000007FE000007F800000003FE000007F000000001FE00
+000FF000000001FE00001FF000000001FE00001FE000000001FE00001FE000000001FE00
+003FE000000001FE00003FC000000001FE00007FC000000001FE00007FC000000001FE00
+007FC000000001FE00007FC000000001FE00007F8000000001FE0000FF8000000001FE00
+00FF8000000001FE0000FF8000000001FE0000FF8000000001FE0000FF8000000001FE00
+00FF8000000001FE0000FF8000000001FE0000FF8000000001FE0000FF8000000001FE00
+00FF8000000001FE0000FF8000000001FE0000FF8000000001FE0000FF8000000001FE00
+007F8000000001FE00007FC000000001FE00007FC000000001FE00007FC000000001FE00
+003FC000000001FE00003FC000000001FE00003FE000000001FE00001FE000000001FE00
+001FE000000001FE00000FF000000003FE00000FF000000003FE000007F800000007FE00
+0003F800000007FE000003FC0000000FFE000001FE0000001FFE000000FE0000003DFE00
+00007F0000003DFE0000003F800000F9FF0000001FC00001F1FF0000000FF00003C1FFC0
+000007F8000F81FFFF800001FF007F01FFFF8000007FFFFC01FFFF8000001FFFE001FFFF
+80000001FF0001FF000041657CE349>I<000003FE00000000001FFFE000000000FFFFF8
+00000001FE03FE00000007F0007F8000000FE0003FC000003FC0001FE000007F00000FF0
+0000FF000007F80000FE000003F80001FC000003FC0003F8000001FC0007F8000001FE00
+07F0000000FE000FF0000000FF000FF00000007F001FE00000007F001FE00000007F803F
+E00000007F803FC00000003F803FC00000003F807FC00000003FC07FC00000003FC07FC0
+0000003FC07F800000003FC07F800000003FC0FF800000003FC0FFFFFFFFFFFFC0FFFFFF
+FFFFFFC0FFFFFFFFFFFFC0FF800000000000FF800000000000FF800000000000FF800000
+000000FF800000000000FF800000000000FF800000000000FF800000000000FF80000000
+00007F8000000000007FC000000000007FC000000000007FC000000000003FC000000000
+003FC000000000003FE000000000001FE000000000001FE000000001C00FF000000001C0
+0FF000000003C007F8000000038007F8000000038003FC000000078001FC0000000F0001
+FE0000000E0000FF0000001E00007F8000003C00003FC000007800001FE00000F0000007
+F00003E0000003FC0007C0000000FF803F000000003FFFFC000000000FFFF00000000001
+FF80000032417CBF3A>I<0000000000003F80000003FC0001FFE000003FFFC007FFF000
+00FFFFF01FC1F80003FC03FC3E03F80007F000FE7803F8000FE0007FE003F8001FC0003F
+C003F8003F80001FC001F0007F00000FE0000000FE000007F0000000FE000007F0000001
+FC000003F8000001FC000003F8000003FC000003FC000003FC000003FC000003F8000001
+FC000007F8000001FE000007F8000001FE000007F8000001FE000007F8000001FE000007
+F8000001FE000007F8000001FE000007F8000001FE000007F8000001FE000007F8000001
+FE000007F8000001FE000003F8000001FC000003FC000003FC000003FC000003FC000001
+FC000003F8000001FC000003F8000000FE000007F0000000FE000007F00000007F00000F
+E00000003F80001FC00000001FC0003F800000003FE0007F0000000037F000FE00000000
+73FC03FC0000000060FFFFF000000000E03FFFC000000000E003FC0000000001C0000000
+00000001C000000000000001C000000000000001C000000000000001C000000000000001
+E000000000000001E000000000000001F000000000000001F000000000000001F8000000
+00000000FC00000000000000FF00000000000000FFFFFFFE000000007FFFFFFFF0000000
+3FFFFFFFFE0000001FFFFFFFFF8000000FFFFFFFFFE000000FFFFFFFFFF000003FFFFFFF
+FFFC0000FE000001FFFE0003F80000001FFE0007E000000003FF000FC000000000FF801F
+80000000007F803F80000000003FC03F00000000001FC07E00000000001FC07E00000000
+000FE0FE00000000000FE0FC000000000007E0FC000000000007E0FC000000000007E0FC
+000000000007E0FC000000000007E0FC000000000007E0FE00000000000FE07E00000000
+000FC07E00000000000FC07F00000000001FC03F80000000003F801FC0000000007F000F
+C0000000007E0007F000000001FC0003F800000003F80001FC00000007F000007F000000
+1FC000003FE00000FF8000000FFE000FFE00000001FFFFFFF0000000003FFFFF80000000
+0001FFF00000003D5E7DBF42>103 D<0003C000000000000007FFC0000000000000FFFF
+C0000000000000FFFFC0000000000000FFFFC0000000000000FFFFC000000000000001FF
+C0000000000000007FC0000000000000007FC0000000000000003FC0000000000000003F
+C0000000000000003FC0000000000000003FC0000000000000003FC0000000000000003F
+C0000000000000003FC0000000000000003FC0000000000000003FC0000000000000003F
+C0000000000000003FC0000000000000003FC0000000000000003FC0000000000000003F
+C0000000000000003FC0000000000000003FC0000000000000003FC0000000000000003F
+C0000000000000003FC0000000000000003FC0000000000000003FC0000000000000003F
+C0000000000000003FC0000000000000003FC0000000000000003FC0000000000000003F
+C0000000000000003FC0000000000000003FC0000000000000003FC0007FE0000000003F
+C003FFFC000000003FC00FFFFF000000003FC03F00FFC00000003FC078001FE00000003F
+C0F0000FF00000003FC1C00007F80000003FC3800007FC0000003FC7000003FC0000003F
+CE000003FE0000003FCE000001FE0000003FDC000001FE0000003FD8000001FE0000003F
+F8000000FF0000003FF0000000FF0000003FF0000000FF0000003FF0000000FF0000003F
+E0000000FF0000003FE0000000FF0000003FE0000000FF0000003FC0000000FF0000003F
+C0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003F
+C0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003F
+C0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003F
+C0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003F
+C0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003F
+C0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003F
+C0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003F
+C0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003F
+C0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000007F
+E0000001FF800000FFF0000003FFC000FFFFFFF003FFFFFFC0FFFFFFF003FFFFFFC0FFFF
+FFF003FFFFFFC0FFFFFFF003FFFFFFC042647DE349>I<003C000000FF000001FF800003
+FFC00003FFC00003FFC00003FFC00003FFC00003FFC00001FF800000FF0000003C000000
+000000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000003C00007FFC0007FFFC0007FFFC0007FFFC0007FFFC00001FFC00000
+7FC000007FC000003FC000003FC000003FC000003FC000003FC000003FC000003FC00000
+3FC000003FC000003FC000003FC000003FC000003FC000003FC000003FC000003FC00000
+3FC000003FC000003FC000003FC000003FC000003FC000003FC000003FC000003FC00000
+3FC000003FC000003FC000003FC000003FC000003FC000003FC000003FC000003FC00000
+3FC000003FC000003FC000003FC000003FC000003FC000003FC000003FC000003FC00000
+3FC000003FC000003FC000003FC000003FC000007FE00000FFF000FFFFFFE0FFFFFFE0FF
+FFFFE0FFFFFFE01B5F7DDE23>I<0003C000FFC0000007FE00000007FFC003FFF800001F
+FFC00000FFFFC00FFFFE00007FFFF00000FFFFC03F00FF8001F807FC0000FFFFC078003F
+C003C001FE0000FFFFC1E0001FE00F0000FF000001FFC3C0000FF01E00007F8000007FC3
+800007F81C00003FC000007FC7000007F83800003FC000003FCE000003FC7000001FE000
+003FCC000003FC6000001FE000003FDC000003FCE000001FE000003FD8000003FCC00000
+1FE000003FF8000001FFC000000FF000003FF0000001FF8000000FF000003FF0000001FF
+8000000FF000003FE0000001FF0000000FF000003FE0000001FF0000000FF000003FE000
+0001FF0000000FF000003FE0000001FF0000000FF000003FC0000001FE0000000FF00000
+3FC0000001FE0000000FF000003FC0000001FE0000000FF000003FC0000001FE0000000F
+F000003FC0000001FE0000000FF000003FC0000001FE0000000FF000003FC0000001FE00
+00000FF000003FC0000001FE0000000FF000003FC0000001FE0000000FF000003FC00000
+01FE0000000FF000003FC0000001FE0000000FF000003FC0000001FE0000000FF000003F
+C0000001FE0000000FF000003FC0000001FE0000000FF000003FC0000001FE0000000FF0
+00003FC0000001FE0000000FF000003FC0000001FE0000000FF000003FC0000001FE0000
+000FF000003FC0000001FE0000000FF000003FC0000001FE0000000FF000003FC0000001
+FE0000000FF000003FC0000001FE0000000FF000003FC0000001FE0000000FF000003FC0
+000001FE0000000FF000003FC0000001FE0000000FF000003FC0000001FE0000000FF000
+003FC0000001FE0000000FF000003FC0000001FE0000000FF000003FC0000001FE000000
+0FF000003FC0000001FE0000000FF000003FC0000001FE0000000FF000003FC0000001FE
+0000000FF000003FC0000001FE0000000FF000003FC0000001FE0000000FF000003FC000
+0001FE0000000FF000003FC0000001FE0000000FF000003FC0000001FE0000000FF00000
+7FE0000003FF0000001FF80000FFF0000007FF8000003FFC00FFFFFFF007FFFFFF803FFF
+FFFCFFFFFFF007FFFFFF803FFFFFFCFFFFFFF007FFFFFF803FFFFFFCFFFFFFF007FFFFFF
+803FFFFFFC663F7CBE6F>109 D<0003C0007FE000000007FFC003FFFC000000FFFFC00F
+FFFF000000FFFFC03F00FFC00000FFFFC078001FE00000FFFFC0F0000FF0000001FFC1C0
+0007F80000007FC3800007FC0000007FC7000003FC0000003FCE000003FE0000003FCE00
+0001FE0000003FDC000001FE0000003FD8000001FE0000003FF8000000FF0000003FF000
+0000FF0000003FF0000000FF0000003FF0000000FF0000003FE0000000FF0000003FE000
+0000FF0000003FE0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC000
+0000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC000
+0000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC000
+0000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC000
+0000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC000
+0000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC000
+0000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC000
+0000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC000
+0000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC000
+0000FF0000003FC0000000FF0000003FC0000000FF0000007FE0000001FF800000FFF000
+0003FFC000FFFFFFF003FFFFFFC0FFFFFFF003FFFFFFC0FFFFFFF003FFFFFFC0FFFFFFF0
+03FFFFFFC0423F7DBE49>I<000000FF8000000000000FFFF800000000003FFFFE000000
+0000FF007F8000000003FC001FE000000007F00007F00000000FC00001F80000003F8000
+00FE0000007F0000007F0000007E0000003F000000FC0000001F800001F80000000FC000
+03F80000000FE00003F000000007E00007F000000007F0000FE000000003F8000FE00000
+0003F8001FE000000003FC001FC000000001FC001FC000000001FC003FC000000001FE00
+3FC000000001FE003FC000000001FE007F8000000000FF007F8000000000FF007F800000
+0000FF007F8000000000FF00FF8000000000FF80FF8000000000FF80FF8000000000FF80
+FF8000000000FF80FF8000000000FF80FF8000000000FF80FF8000000000FF80FF800000
+0000FF80FF8000000000FF80FF8000000000FF80FF8000000000FF80FF8000000000FF80
+7F8000000000FF007F8000000000FF007FC000000001FF007FC000000001FF003FC00000
+0001FE003FC000000001FE003FC000000001FE001FE000000003FC001FE000000003FC00
+1FE000000003FC000FF000000007F80007F000000007F00007F000000007F00003F80000
+000FE00001FC0000001FC00001FC0000001FC00000FE0000003F8000007F0000007F0000
+003F800000FE0000001FC00001FC0000000FF00007F800000003FC001FE000000000FF00
+7F80000000007FFFFF00000000000FFFF8000000000001FFC000000039417CBF42>I<00
+00FFE00180000FFFFC0380007FFFFF078001FF001FCF8003F80003EF8007E00001FF800F
+C00000FF801F8000007F803F0000003F803E0000001F807E0000000F807C0000000F807C
+0000000F80FC0000000780FC0000000780FC0000000780FC0000000380FE0000000380FE
+0000000380FF0000000380FF80000003807FC0000003807FE0000000007FF8000000003F
+FE000000001FFFF00000000FFFFF80000007FFFFF8000003FFFFFF000001FFFFFFC00000
+7FFFFFF000001FFFFFF8000007FFFFFE0000007FFFFF00000003FFFF800000003FFFC000
+000003FFC000000000FFE0000000007FE0E00000001FF0E00000000FF0E00000000FF8F0
+00000007F8F000000003F8F000000003F8F000000003F8F800000001F8F800000001F8F8
+00000001F8FC00000001F8FC00000001F8FE00000001F0FE00000003F0FF00000003F0FF
+00000003E0FF80000007E0FFC000000FC0FFE000000F80FDF000001F80F8F800007F00F8
+3E0000FC00F01FC00FF800F007FFFFE000E001FFFF8000C0003FF800002D417DBF34>
+115 D<000038000000000038000000000038000000000038000000000038000000000038
+0000000000380000000000780000000000780000000000780000000000780000000000F8
+0000000000F80000000000F80000000001F80000000001F80000000001F80000000003F8
+0000000003F80000000007F8000000000FF8000000001FF8000000001FF8000000007FF8
+00000000FFF800000003FFF80000000FFFFFFFFF00FFFFFFFFFF00FFFFFFFFFF00FFFFFF
+FFFF000007F80000000007F80000000007F80000000007F80000000007F80000000007F8
+0000000007F80000000007F80000000007F80000000007F80000000007F80000000007F8
+0000000007F80000000007F80000000007F80000000007F80000000007F80000000007F8
+0000000007F80000000007F80000000007F80000000007F80000000007F80000000007F8
+0000000007F80000000007F80000000007F80000000007F80000000007F80000000007F8
+0000000007F80000000007F80000000007F80000E00007F80000E00007F80000E00007F8
+0000E00007F80000E00007F80000E00007F80000E00007F80000E00007F80000E00007F8
+0000E00007F80000E00007F80000E00007F80000E00007F80000E00003FC0001C00003FC
+0001C00003FC0001C00003FC0003C00001FE0003800001FE0007800000FF00070000007F
+800F0000003FC01E0000001FF07C0000000FFFF800000003FFE0000000007F80002B597F
+D733>I<FFFFFF801FFFFFE000FFFFF8FFFFFF801FFFFFE000FFFFF8FFFFFF801FFFFFE0
+00FFFFF8FFFFFF801FFFFFE000FFFFF803FFF000007FFC00001FFF8000FFC000003FF000
+0007FE0000FFC000001FF0000003FC00007FC000000FF0000001F800007FC000000FF000
+0001F000003FC000000FF0000001F000003FC0000007F0000001E000003FE0000007F800
+0001E000001FE000000FF8000001C000001FE000000FF8000001C000001FF000000FFC00
+0003C000000FF000001FFC0000038000000FF000001DFC0000038000000FF800001DFE00
+000780000007F800003DFE00000700000007F8000038FE00000700000007FC000038FF00
+000F00000003FC000078FF00000E00000003FC0000707F00000E00000003FE0000707F80
+001E00000001FE0000F07F80001C00000001FE0000E03F80001C00000001FF0000E03FC0
+003C00000000FF0001E03FC0003800000000FF0001C01FC0003800000000FF8001C01FE0
+0078000000007F8003C01FE00070000000007F8003800FE00070000000007FC003800FF0
+00F0000000003FC007800FF000E0000000003FC0070007F000E0000000003FE0070007F8
+01E0000000001FE00F0007F801C0000000001FE00E0003F801C0000000001FF00E0003FC
+03C0000000000FF01E0003FC0380000000000FF01C0001FC0380000000000FF81C0001FE
+07800000000007F83C0001FE07000000000007F8380000FE07000000000007FC380000FF
+0F000000000003FC780000FF0E000000000003FC7000007F0E000000000003FE7000007F
+9E000000000001FEF000007F9C000000000001FEE000003F9C000000000001FFE000003F
+FC000000000000FFE000003FF8000000000000FFC000001FF8000000000000FFC000001F
+F80000000000007FC000001FF00000000000007F8000000FF00000000000007F8000000F
+F00000000000003F8000000FE00000000000003F00000007E00000000000003F00000007
+E00000000000001F00000007C00000000000001E00000003C00000000000000E00000003
+800000005D3F7FBD60>119 D E end
+%%EndProlog
+%%BeginSetup
+%%Feature: *Resolution 600dpi
+TeXDict begin
+%%PaperSize: Letter
+
+%%EndSetup
+%%Page: 1 1
+1 0 bop 1090 872 a Fp(Using)44 b(C)f(co)t(de)h(with)g(Sc)l(heme)h(48)
+1661 1112 y Fo(Mik)m(e)33 b(Sp)s(erb)s(er)1260 1229 y
+Fn(sperber@informatik.uni-tueb)q(ingen)q(.de)1623 1345
+y Fo(Ric)m(hard)g(Kelsey)1437 1461 y Fn(kelsey@research.nj.nec.com)1563
+1657 y Fo(F)-8 b(ebruary)33 b(23,)f(1999)1778 1955 y
+Fm(Abstract)837 2086 y Fl(This)41 b(do)r(cumen)n(t)e(describ)r(es)i(an)
+f(in)n(terface)h(for)g(calling)h(C)e(functions)h(from)722
+2177 y(Sc)n(heme,)32 b(calling)g(Sc)n(heme)e(functions)i(from)f(C,)h
+(and)f(allo)r(cating)i(storage)g(in)e(the)722 2268 y(Sc)n(heme)21
+b(heap.)33 b(These)22 b(facilities)j(are)d(designed)g(to)h(link)e
+(existing)i(C)f(libraries)h(in)n(to)722 2360 y(Sc)n(heme)30
+b(48)j(in)e(order)h(to)g(use)g(them)e(from)h(Sc)n(heme.)51
+b(T)-6 b(o)32 b(this)g(end,)g(Sc)n(heme)f(48)722 2451
+y(manages)f(stub)f(functions)h(in)g(C)g(that)f(negotiate)i(b)r(et)n(w)n
+(een)e(the)g(calling)j(con)n(v)n(en-)722 2542 y(tions)23
+b(of)g(Sc)n(heme)e(and)h(C)h(and)f(the)g(memory)e(allo)r(cation)25
+b(p)r(olicies)f(of)f(b)r(oth)f(w)n(orlds.)722 2634 y(No)27
+b(stub)g(generator)h(is)f(a)n(v)l(ailable)h(y)n(et,)f(but)f(writing)i
+(them)e(is)h(a)g(straigh)n(tforw)n(ard)722 2725 y(task.)515
+2999 y Fk(1)134 b(Av)-7 b(ailable)46 b(F)-11 b(acilities)515
+3181 y Fj(The)27 b(follo)n(wing)g(facilities)h(are)e(a)n(v)-5
+b(ailable)26 b(for)i(in)n(terfacing)e(b)r(et)n(w)n(een)i(Sc)n(heme)f
+(48)g(and)g(C:)639 3347 y Fi(\017)41 b Fj(Sc)n(heme)28
+b(co)r(de)f(can)g(call)h(C)f(functions.)639 3513 y Fi(\017)41
+b Fj(The)32 b(external)f(in)n(terface)g(pro)n(vides)f(full)i(in)n
+(trosp)r(ection)f(for)h(all)f(Sc)n(heme)g(ob)5 b(jects.)722
+3613 y(External)25 b(co)r(de)g(ma)n(y)g(insp)r(ect,)i(mo)r(dify)-7
+b(,)26 b(and)g(allo)r(cate)f(Sc)n(heme)g(ob)5 b(jects)25
+b(arbitrar-)722 3713 y(ily)-7 b(.)639 3879 y Fi(\017)41
+b Fj(External)27 b(co)r(de)g(ma)n(y)g(raise)f(exceptions)h(bac)n(k)g
+(to)h(Sc)n(heme)f(48)g(to)g(signal)g(errors.)639 4045
+y Fi(\017)41 b Fj(External)23 b(co)r(de)g(ma)n(y)h(call)f(bac)n(k)g(in)
+n(to)g(Sc)n(heme.)36 b(Sc)n(heme)24 b(48)e(correctly)h(unrolls)g(the)
+722 4144 y(pro)r(cess)k(stac)n(k)f(on)i(non-lo)r(cal)e(exits.)639
+4310 y Fi(\017)41 b Fj(External)25 b(mo)r(dules)h(ma)n(y)f(register)f
+(bindings)i(of)f(names)g(to)h(v)-5 b(alues)25 b(with)i(a)e(cen)n(tral)
+722 4410 y(registry)37 b(accessible)g(from)g(Sc)n(heme.)69
+b(Con)n(v)n(ersely)-7 b(,)38 b(Sc)n(heme)g(co)r(de)g(can)g(register)722
+4510 y(shared)27 b(bindings)g(for)h(access)e(b)n(y)h(C)h(co)r(de.)515
+4676 y(This)39 b(do)r(cumen)n(t)h(has)e(three)i(parts:)59
+b(the)40 b(\014rst)f(describ)r(es)g(ho)n(w)f(bindings)i(are)e(mo)n(v)n
+(ed)515 4775 y(from)26 b(Sc)n(heme)h(to)g(C)f(and)h(vice)g(v)n(ersa,)e
+(the)i(second)f(tells)h(ho)n(w)f(to)h(call)f(C)h(functions)g(from)515
+4875 y(Sc)n(heme,)21 b(and)g(the)f(third)h(co)n(v)n(ers)d(the)j(C)f(in)
+n(terface)g(to)g(Sc)n(heme)g(ob)5 b(jects,)21 b(including)g(calling)515
+4975 y(Sc)n(heme)27 b(pro)r(cedures,)g(using)g(the)h(Sc)n(heme)f(heap,)
+h(and)f(so)g(forth.)1926 5255 y(1)p eop
+%%Page: 2 2
+2 1 bop 515 523 a Fh(1.1)112 b(Sc)m(heme)37 b(structures)515
+676 y Fj(The)19 b(structure)f Fg(external-calls)13 b
+Fj(has)18 b(most)h(of)g(the)g(Sc)n(heme)g(functions)g(describ)r(ed)f
+(here.)515 776 y(The)37 b(others)f(are)g(in)h Fg(dynamic-externals)o
+Fj(,)d(whic)n(h)j(has)f(the)h(functions)h(for)e(dynamic)515
+876 y(loading)e(and)h(name)g(lo)r(okup)f(from)h(Section)g(5,)74
+b(and)35 b Fg(shared-bindings)o Fj(,)d(whic)n(h)j(has)515
+975 y(the)28 b(additional)f(shared-binding)f(functions)i(describ)r(ed)f
+(in)h(Section)g(2.3.)515 1208 y Fh(1.2)112 b(C)37 b(naming)g(con)m(v)m
+(en)m(tions)515 1361 y Fj(The)30 b(names)g(of)g(all)g(of)h(Sc)n(heme)f
+(48's)f(visible)h(C)h(bindings)f(b)r(egin)h(with)f(`)p
+Fg(s48)p 2990 1361 27 4 v 31 w Fj(')g(\(for)g(pro-)515
+1460 y(cedures)i(and)g(v)-5 b(ariables\))32 b(or)g(`)p
+Fg(S48)p 1631 1460 V 30 w Fj(')h(\(for)f(macros\).)52
+b(Whenev)n(er)32 b(a)g(C)h(name)f(is)h(deriv)n(ed)515
+1560 y(from)24 b(a)h(Sc)n(heme)g(iden)n(ti\014er,)g(w)n(e)g(replace)f
+(`)p Fg(-)p Fj(')h(with)g(`)p 2167 1560 V 32 w(')g(and)f(con)n(v)n(ert)
+g(letters)h(to)g(lo)n(w)n(ercase)515 1660 y(for)f(pro)r(cedures)g(and)g
+(upp)r(ercase)g(for)h(macros.)34 b(A)25 b(\014nal)g(`)p
+Fg(?)p Fj(')36 b(con)n(v)n(erted)23 b(to)i(`)p 2929 1660
+V 31 w Fg(p)p Fj(')g(\(`)p 3107 1660 V 31 w Fg(P)p Fj(')g(in)g(C)515
+1759 y(macro)f(names\).)36 b(A)25 b(\014nal)g(`)p Fg(!)p
+Fj(')36 b(is)25 b(dropp)r(ed.)36 b(Th)n(us)25 b(the)g(C)h(macro)e(for)g
+(Sc)n(heme's)h Fg(pair?)34 b Fj(is)515 1859 y Fg(S48)p
+652 1859 V 30 w(PAIR)p 858 1859 V 30 w(P)29 b Fj(and)g(the)h(one)f(for)
+g Fg(set-car!)39 b Fj(is)29 b Fg(S48)p 2160 1859 V 30
+w(SET)p 2322 1859 V 30 w(CAR)p Fj(.)g(Pro)r(cedures)e(and)j(macros)515
+1959 y(that)e(do)f(not)h(c)n(hec)n(k)e(the)i(t)n(yp)r(es)g(of)f(their)h
+(argumen)n(ts)e(ha)n(v)n(e)h(`)p Fg(unsafe)p Fj(')e(in)j(their)f
+(names.)639 2058 y(All)k(of)f(the)h(C)f(functions)h(and)f(macros)e
+(describ)r(ed)i(ha)n(v)n(e)f(protot)n(yp)r(es)h(or)f(de\014nitions)515
+2158 y(in)g(the)g(\014le)g Fg(c/scheme48.h)p Fj(.)37
+b(The)29 b(C)g(t)n(yp)r(e)g(for)f(Sc)n(heme)h(v)-5 b(alues)29
+b(is)g(de\014ned)g(there)g(to)g(b)r(e)515 2257 y Fg(s48)p
+652 2257 V 30 w(value)p Fj(.)515 2532 y Fk(2)134 b(Shared)45
+b(bindings)515 2714 y Fj(Shared)c(bindings)h(are)f(the)h(means)f(b)n(y)
+h(whic)n(h)f(named)h(v)-5 b(alues)41 b(are)g(shared)g(b)r(et)n(w)n(een)
+515 2813 y(Sc)n(heme)35 b(co)r(de)h(and)f(C)h(co)r(de.)61
+b(There)35 b(are)f(t)n(w)n(o)h(separate)f(tables)i(of)f(shared)g
+(bindings,)515 2913 y(one)28 b(for)g(v)-5 b(alues)29
+b(de\014ned)g(in)g(Sc)n(heme)f(and)h(accessed)e(from)i(C)f(and)h(the)g
+(other)f(for)g(v)-5 b(alues)515 3013 y(going)30 b(the)i(other)f(w)n(a)n
+(y)-7 b(.)47 b(Shared)30 b(bindings)i(actually)f(bind)h(names)e(to)i
+(cells,)g(to)f(allo)n(w)f(a)515 3112 y(name)d(to)h(b)r(e)g(lo)r(ok)n
+(ed)f(up)h(b)r(efore)f(it)i(has)e(b)r(een)h(assigned.)36
+b(This)28 b(is)g(necessary)e(b)r(ecause)h(C)515 3212
+y(initialization)j(co)r(de)h(ma)n(y)f(b)r(e)h(run)g(b)r(efore)f(or)g
+(after)h(the)g(corresp)r(onding)e(Sc)n(heme)h(co)r(de,)515
+3312 y(dep)r(ending)25 b(on)f(whether)h(the)g(Sc)n(heme)g(co)r(de)g(is)
+f(in)i(the)f(resumed)f(image)g(or)g(is)h(run)g(in)g(the)515
+3411 y(curren)n(t)h(session.)515 3644 y Fh(2.1)112 b(Exp)s(orting)36
+b(Sc)m(heme)i(v)-6 b(alues)37 b(to)g(C)531 3797 y Fi(\017)k
+Fg(\(define-exported-)o(bi)o(ndi)o(ng)35 b Ff(name)42
+b(value)6 b Fg(\))42 b Fi(!)f Ff(shar)l(e)l(d-binding)531
+3946 y Fi(\017)g Fg(s48)p 751 3946 V 31 w(value)e(s48)p
+1173 3946 V 30 w(get)p 1335 3946 V 30 w(imported)p 1717
+3946 V 28 w(binding\(char)e(*name\))531 4046 y Fi(\017)k
+Fg(s48)p 751 4046 V 31 w(value)e(S48)p 1173 4046 V 30
+w(SHARED)p 1467 4046 V 29 w(BINDING)p 1804 4046 V 28
+w(REF\(s48)p 2140 4046 V 29 w(value)g(shared)p 2692 4046
+V 29 w(binding\))515 4195 y(Define-exported-)o(bi)o(nd)o(ing)34
+b Fj(mak)n(es)40 b Ff(value)h Fj(a)n(v)-5 b(ailable)39
+b(to)i(C)g(co)r(de)f(under)h(as)f Ff(name)515 4295 y
+Fj(whic)n(h)23 b(m)n(ust)h(b)r(e)h(a)e Ff(string)p Fj(,)h(creating)f(a)
+g(new)h(shared)f(binding)h(if)g(necessary)-7 b(.)34 b(The)24
+b(C)g(func-)515 4395 y(tion)34 b Fg(s48)p 829 4395 V
+30 w(get)p 991 4395 V 30 w(imported)p 1373 4395 V 28
+w(binding)e Fj(returns)h(the)i(shared)e(binding)h(de\014ned)h(for)f
+Fg(name)p Fj(,)515 4494 y(again)c(creating)g(it)h(if)h(necessary)-7
+b(.)46 b(The)31 b(C)h(macro)e Fg(S48)p 2288 4494 V 30
+w(SHARED)p 2582 4494 V 29 w(BINDING)p 2919 4494 V 28
+w(REF)g Fj(derefer-)515 4594 y(ences)d(a)g(shared)g(binding,)h
+(returning)e(its)i(curren)n(t)f(v)-5 b(alue.)515 4826
+y Fh(2.2)112 b(Exp)s(orting)36 b(C)i(v)-6 b(alues)37
+b(to)g(Sc)m(heme)531 4980 y Fi(\017)k Fg(void)f(s48)p
+967 4980 V 30 w(define)p 1261 4980 V 29 w(exported)p
+1642 4980 V 28 w(binding\(char)d(*name,)i(s48)p 2670
+4980 V 30 w(value)g(value\))1926 5255 y Fj(2)p eop
+%%Page: 3 3
+3 2 bop 531 523 a Fi(\017)41 b Fg(\(lookup-imported-)o(bi)o(ndi)o(ng)35
+b Ff(string)7 b Fg(\))41 b Fi(!)h Ff(shar)l(e)l(d-binding)531
+623 y Fi(\017)f Fg(\(shared-binding-r)o(ef)35 b Ff(shar)l(e)l
+(d-binding)7 b Fg(\))43 b Fi(!)f Ff(value)515 740 y Fj(These)f(are)g
+(used)h(to)g(de\014ne)g(shared)f(bindings)h(from)f(C)h(and)g(to)f
+(access)g(them)h(from)515 840 y(Sc)n(heme.)35 b(Again,)24
+b(if)g(a)f(name)g(is)g(lo)r(ok)n(ed)g(up)g(b)r(efore)g(it)h(has)f(b)r
+(een)h(de\014ned,)g(a)f(new)h(binding)515 940 y(is)j(created)g(for)g
+(it.)639 1039 y(The)32 b(common)g(case)f(of)h(exp)r(orting)g(a)f(C)i
+(function)f(to)g(Sc)n(heme)g(can)g(b)r(e)h(done)e(using)515
+1139 y(the)d(macro)e Fg(S48)p 1044 1139 27 4 v 30 w(EXPORT)p
+1338 1139 V 29 w(FUNCTION\()p Fe(name)9 b Fg(\))p Fj(.)37
+b(This)27 b(expands)g(in)n(to)639 1238 y Fg(s48)p 776
+1238 V 30 w(define)p 1070 1238 V 29 w(exported)p 1451
+1238 V 28 w(binding\(")p Ff(name)p Fg(",)40 b(s48)p 2330
+1238 V 30 w(enter)p 2580 1238 V 29 w(pointer\()p Ff(name)p
+Fg(\)\))515 1338 y Fj(whic)n(h)29 b(b)r(o)n(xes)g(the)g(function)h(in)n
+(to)f(a)g(Sc)n(heme)g(b)n(yte)h(v)n(ector)e(and)h(then)h(exp)r(orts)e
+(it.)43 b(Note)515 1438 y(that)28 b Fg(s48)p 832 1438
+V 30 w(enter)p 1082 1438 V 29 w(pointer)e Fj(allo)r(cates)g(space)i(in)
+g(the)g(Sc)n(heme)g(heap)g(and)g(migh)n(t)g(trigger)515
+1537 y(a)f(garbage)e(collection;)i(see)g(Section)h(9.)531
+1655 y Fi(\017)41 b Fg(\(import-definitio)o(n)35 b Ff(name)p
+Fg(\))1462 b Fj(syn)n(tax)531 1754 y Fi(\017)41 b Fg
+(\(import-definitio)o(n)35 b Ff(name)42 b(c-name)p Fg(\))1157
+b Fj(syn)n(tax)515 1872 y(These)31 b(macros)g(simplify)h(imp)r(orting)f
+(de\014nitions)h(from)g(C)g(to)f(Sc)n(heme.)50 b(They)31
+b(expand)515 1972 y(in)n(to)639 2071 y Fg(\(define)41
+b Ff(name)j Fg(\(lookup-imported)o(-b)o(in)o(din)o(g)37
+b Ff(c-name)p Fg(\)\))515 2171 y Fj(where)30 b Ff(c-name)g
+Fj(is)h(as)f(supplied)h(for)f(the)h(second)f(form.)45
+b(F)-7 b(or)30 b(the)h(\014rst)f(form)g Ff(c-name)h Fj(is)515
+2271 y(deriv)n(ed)26 b(from)g Ff(name)h Fj(b)n(y)g(replacing)e(`)p
+Fg(-)p Fj(')i(with)g(`)p 2024 2271 V 32 w(')g(and)f(con)n(v)n(erting)f
+(letters)i(to)g(lo)n(w)n(ercase.)515 2370 y(F)-7 b(or)27
+b(example,)g Fg(\(import-definiti)o(on)37 b(my-foo\))25
+b Fj(expands)i(in)n(to)639 2470 y Fg(\(define)41 b(my-foo)g
+(\(lookup-imported)o(-bi)o(nd)o(ing)c("my)p 2520 2470
+V 30 w(foo"\)\))515 2695 y Fh(2.3)112 b(Complete)36 b(shared)j(binding)
+d(in)m(terface)515 2849 y Fj(There)24 b(are)f(a)h(n)n(um)n(b)r(er)h(of)
+f(other)g(Sc)n(heme)h(functions)g(related)e(to)i(shared)e(bindings;)j
+(these)515 2948 y(are)g(in)i(the)g(structure)f Fg(shared-bindings)p
+Fj(.)531 3066 y Fi(\017)41 b Fg(\(shared-binding?)j Ff(x)10
+b Fg(\))40 b Fi(!)i Ff(b)l(o)l(ole)l(an)531 3165 y Fi(\017)f
+Fg(\(shared-binding-n)o(am)o(e)36 b Ff(shar)l(e)l(d-binding)7
+b Fg(\))43 b Fi(!)e Ff(string)531 3265 y Fi(\017)g Fg
+(\(shared-binding-i)o(s-)o(imp)o(or)o(t?)j Ff(shar)l(e)l(d-binding)7
+b Fg(\))43 b Fi(!)e Ff(b)l(o)l(ole)l(an)531 3365 y Fi(\017)g
+Fg(\(shared-binding-s)o(et)o(!)36 b Ff(shar)l(e)l(d-binding)43
+b(value)6 b Fg(\))531 3464 y Fi(\017)41 b Fg(\(define-imported-)o(bi)o
+(ndi)o(ng)35 b Ff(string)41 b(value)6 b Fg(\))531 3564
+y Fi(\017)41 b Fg(\(lookup-exported-)o(bi)o(ndi)o(ng)35
+b Ff(string)7 b Fg(\))531 3664 y Fi(\017)41 b Fg(\(undefine-importe)o
+(d-)o(bin)o(di)o(ng)35 b Ff(string)7 b Fg(\))531 3763
+y Fi(\017)41 b Fg(\(undefine-exporte)o(d-)o(bin)o(di)o(ng)35
+b Ff(string)7 b Fg(\))515 3881 y(Shared-binding?)31 b
+Fj(is)d(the)h(predicate)e(for)g(shared-bindings.)37 b
+Fg(Shared-binding-n)o(am)o(e)515 3980 y Fj(returns)19
+b(the)h(name)f(of)h(a)f(binding.)35 b Fg(Shared-binding-)o(is-)o(im)o
+(po)o(rt?)27 b Fj(is)20 b(true)g(if)g(the)g(bind-)515
+4080 y(ing)26 b(w)n(as)f(de\014ned)h(from)g(C.)g Fg(Shared-binding-se)o
+(t!)k Fj(c)n(hanges)25 b(the)h(v)-5 b(alue)26 b(of)g(a)g(binding.)515
+4180 y Fg(Define-imported-)o(bi)o(nd)o(ing)34 b Fj(and)41
+b Fg(lookup-exported-b)o(ind)o(in)o(g)35 b Fj(are)40
+b(Sc)n(heme)h(v)n(er-)515 4279 y(sions)i(of)51 b Fg(s48)p
+990 4279 V 30 w(define)p 1284 4279 V 29 w(exported)p
+1665 4279 V 28 w(binding)42 b Fj(and)i Fg(s48)p 2353
+4279 V 30 w(lookup)p 2647 4279 V 29 w(imported)p 3028
+4279 V 28 w(binding)p Fj(.)515 4379 y(The)38 b(t)n(w)n(o)f
+Fg(undefine-)e Fj(pro)r(cedures)i(remo)n(v)n(e)f(bindings)i(from)g(the)
+h(t)n(w)n(o)e(tables.)68 b(They)515 4479 y(do)27 b(nothing)g(if)i(the)f
+(name)f(is)g(not)h(found)g(in)g(the)g(table.)639 4578
+y(The)g(follo)n(wing)e(C)i(macros)e(corresp)r(ond)g(to)i(the)g(Sc)n
+(heme)f(functions)h(ab)r(o)n(v)n(e.)531 4696 y Fi(\017)41
+b Fg(int)290 b(S48)p 1173 4696 V 30 w(SHARED)p 1467 4696
+V 29 w(BINDING)p 1804 4696 V 28 w(P\(x\))531 4795 y Fi(\017)41
+b Fg(int)290 b(S48)p 1173 4795 V 30 w(SHARED)p 1467 4795
+V 29 w(BINDING)p 1804 4795 V 28 w(IS)p 1920 4795 V 31
+w(IMPORT)p 2215 4795 V 29 w(P\(s48)p 2464 4795 V 29 w(value)39
+b(s)p 2796 4795 V 31 w(b\))531 4895 y Fi(\017)i Fg(s48)p
+751 4895 V 31 w(value)e(S48)p 1173 4895 V 30 w(SHARED)p
+1467 4895 V 29 w(BINDING)p 1804 4895 V 28 w(NAME\(s48)p
+2184 4895 V 29 w(value)g(s)p 2516 4895 V 31 w(b\))531
+4995 y Fi(\017)i Fg(void)248 b(S48)p 1175 4995 V 30 w(SHARED)p
+1469 4995 V 29 w(BINDING)p 1806 4995 V 28 w(SET\(s48)p
+2142 4995 V 29 w(value)39 b(s)p 2474 4995 V 31 w(b,)i(s48)p
+2766 4995 V 30 w(value)e(value\))1926 5255 y Fj(3)p eop
+%%Page: 4 4
+4 3 bop 515 523 a Fk(3)134 b(Calling)47 b(C)e(F)-11 b(unctions)44
+b(from)h(Sc)l(heme)515 705 y Fj(There)30 b(are)g(three)h(di\013eren)n
+(t)g(w)n(a)n(ys)f(to)h(call)f(C)h(functions)h(from)e(Sc)n(heme,)i(dep)r
+(ending)f(on)515 805 y(ho)n(w)c(the)h(C)f(function)h(w)n(as)f
+(obtained.)531 953 y Fi(\017)41 b Fg(\(call-imported-bi)o(nd)o(ing)35
+b Ff(binding)42 b(ar)l(g)2030 965 y Fd(0)2110 953 y Ff(.)13
+b(.)g(.)g Fg(\))50 b Fi(!)42 b Ff(value)531 1052 y Fi(\017)f
+Fg(\(call-external)36 b Ff(external)41 b(ar)l(g)1706
+1064 y Fd(0)1786 1052 y Ff(.)13 b(.)g(.)g Fg(\))50 b
+Fi(!)42 b Ff(value)531 1152 y Fi(\017)f Fg(\(call-external-va)o(lu)o(e)
+36 b Ff(value)42 b(name)f(ar)l(g)2101 1164 y Fd(0)2181
+1152 y Ff(.)13 b(.)g(.)g Fg(\))50 b Fi(!)42 b Ff(value)515
+1300 y Fj(Eac)n(h)35 b(of)i(these)g(applies)f(its)h(\014rst)f(argumen)n
+(t,)i(a)e(C)h(function,)j(to)c(the)h(rest)g(of)f(the)h(ar-)515
+1400 y(gumen)n(ts.)k(F)-7 b(or)28 b Fg(call-imported-bi)o(ndi)o(ng)23
+b Fj(the)29 b(function)h(argumen)n(t)e(m)n(ust)h(b)r(e)g(an)g(im-)515
+1500 y(p)r(orted)23 b(binding.)35 b(F)-7 b(or)22 b Fg(call-external)c
+Fj(the)23 b(function)h(argumen)n(t)e(m)n(ust)h(b)r(e)g(an)g(external)
+515 1599 y(b)r(ound)i(in)g(the)g(curren)n(t)f(pro)r(cess)g(\(see)h
+(Section)f(5\).)72 b(F)-7 b(or)24 b Fg(call-external-val)o(ue)18
+b Ff(value)515 1699 y Fj(m)n(ust)33 b(b)r(e)i(a)e(b)n(yte)g(v)n(ector)g
+(whose)g(con)n(ten)n(ts)g(is)g(a)g(p)r(oin)n(ter)h(to)f(a)g(C)h
+(function)g(and)g Ff(name)515 1799 y Fj(should)e(b)r(e)g(a)g(string)f
+(naming)h(the)g(function.)51 b(The)32 b Ff(name)h Fj(argumen)n(t)e(is)h
+(used)g(only)g(for)515 1898 y(prin)n(ting)27 b(error)f(messages.)639
+1998 y(F)-7 b(or)41 b(all)g(of)g(these,)k(the)c(C)g(function)h(is)f
+(passed)g(the)g Ff(ar)l(g)2530 2010 y Fc(i)2600 1998
+y Fj(v)-5 b(alues)41 b(and)g(the)g(v)-5 b(alue)515 2097
+y(returned)37 b(is)h(that)g(returned)g(b)n(y)g(C)g(pro)r(cedure.)66
+b(Up)39 b(to)f(t)n(w)n(elv)n(e)f(argumen)n(ts)f(ma)n(y)i(b)r(e)515
+2197 y(passed.)51 b(There)32 b(is)g(no)g(metho)r(d)h(supplied)g(for)f
+(returning)g(m)n(ultiple)h(v)-5 b(alues)32 b(to)g(Sc)n(heme)515
+2297 y(from)23 b(C)h(\(or)f(vice)h(v)n(ersa\))e(\(mainly)i(b)r(ecause)g
+(C)f(do)r(es)h(not)g(ha)n(v)n(e)e(m)n(ultiple)j(return)e(v)-5
+b(alues\).)639 2396 y(Keyb)r(oard)34 b(in)n(terrupts)h(that)g(o)r(ccur)
+g(during)g(a)g(call)g(to)g(a)g(C)g(function)h(are)e(ignored)515
+2496 y(un)n(til)28 b(the)h(function)g(returns)e(to)i(Sc)n(heme)f
+(\(this)g(is)h(clearly)e(a)h(problem;)g(w)n(e)g(are)f(w)n(orking)515
+2596 y(on)g(a)g(solution\).)531 2744 y Fi(\017)41 b Fg
+(\(import-lambda-de)o(fi)o(nit)o(io)o(n)36 b Ff(name)41
+b Fg(\()p Ff(formal)i Fg(...\)\))619 b Fj(syn)n(tax)531
+2844 y Fi(\017)41 b Fg(\(import-lambda-de)o(fi)o(nit)o(io)o(n)36
+b Ff(name)41 b Fg(\()p Ff(formal)i Fg(...\))d Ff(c-name)p
+Fg(\))316 b Fj(syn)n(tax)515 2992 y(These)31 b(macros)e(simplify)j(imp)
+r(orting)f(functions)h(from)f(C.)g(They)g(de\014ne)h
+Ff(name)g Fj(to)f(b)r(e)g(a)515 3092 y(function)26 b(with)g(the)g(giv)n
+(en)f(formals)f(that)i(applies)g(those)f(formals)g(to)g(the)h(corresp)r
+(onding)515 3191 y(C)h(binding.)37 b Ff(C-name)p Fj(,)28
+b(if)h(supplied,)f(should)f(b)r(e)h(a)f(string.)36 b(These)28
+b(expand)f(in)n(to)680 3373 y Fg(\(define)41 b(temp)h
+(\(lookup-imported)o(-b)o(in)o(din)o(g)37 b Ff(c-name)p
+Fg(\)\))680 3472 y(\(define)k Ff(name)767 3572 y Fg(\(lambda)g(\()p
+Ff(formal)k Fg(...\))854 3671 y(\(external-apply)38 b(temp)k
+Ff(formal)j Fg(...\)\)\))545 3853 y Fj(If)31 b Ff(c-name)f
+Fj(is)h(not)f(supplied,)h(it)g(is)f(deriv)n(ed)g(from)g
+Ff(name)g Fj(b)n(y)h(con)n(v)n(erting)d(all)i(letters)g(to)515
+3952 y(lo)n(w)n(ercase)25 b(and)i(replacing)g(`)p Fg(-)p
+Fj(')g(with)h(`)p 1731 3952 27 4 v 32 w('.)515 4227 y
+Fk(4)134 b(Adding)45 b(external)h(mo)t(dules)f(to)g(the)h
+Fb(Makefile)515 4408 y Fj(Getting)35 b(access)f(to)h(C)g(bindings)g
+(from)f(Sc)n(heme)h(requires)f(that)h(the)h(C)f(co)r(de)f(b)r(e)i(com-)
+515 4508 y(piled)f(an)h(link)n(ed)f(in)g(with)h(the)g(Sc)n(heme)f(48)g
+(virtual)g(mac)n(hine)g(and)g(that)g(the)h(relev)n(en)n(t)515
+4608 y(shared-bindings)42 b(b)r(e)h(created.)84 b(The)43
+b(Sc)n(heme)g(48)g(mak)n(e\014le)f(has)h(rules)g(for)f(compil-)515
+4707 y(ing)c(and)g(linking)h(external)e(co)r(de)i(and)f(for)g(sp)r
+(ecifying)h(initialization)f(functions)h(that)515 4807
+y(should)d(b)r(e)h(called)f(on)h(startup.)63 b(There)36
+b(are)g(three)g(Mak)n(e\014le)g(v)-5 b(ariables)35 b(that)i(con)n(trol)
+515 4907 y(whic)n(h)44 b(external)f(mo)r(dules)i(are)e(included)i(in)f
+(the)h(executable)f(for)f(the)i(virutal)f(ma-)515 5006
+y(c)n(hine)39 b(\()p Fg(scheme48vm)p Fj(\).)67 b Fg(EXTERNAL)p
+1692 5006 V 28 w(OBJECTS)36 b Fj(lists)j(the)h(ob)5 b(ject)38
+b(\014les)h(to)g(b)r(e)h(included)1926 5255 y(4)p eop
+%%Page: 5 5
+5 4 bop 515 523 a Fj(in)31 b Fg(scheme48vm)p Fj(,)d Fg(EXTERNAL)p
+1463 523 27 4 v 28 w(FLAGS)h Fj(is)i(a)g(list)g(of)38
+b Fg(ld)30 b Fj(\015ags)g(to)h(b)r(e)h(used)f(when)g(creating)515
+623 y Fg(scheme48vm)p Fj(,)21 b(and)k Fg(EXTERNAL)p 1515
+623 V 28 w(INITIALIZERS)20 b Fj(is)25 b(a)f(list)i(of)f(C)g(pro)r
+(cedures)e(to)i(b)r(e)g(called)515 722 y(on)32 b(startup.)52
+b(The)33 b(pro)r(cedures)e(listed)i(in)g Fg(EXTERNAL)p
+2259 722 V 28 w(INITIALIZERS)28 b Fj(should)k(tak)n(e)g(no)515
+822 y(argumen)n(ts)g(and)i(ha)n(v)n(e)e(a)h(return)g(t)n(yp)r(e)h(of)40
+b Fg(void)p Fj(.)54 b(After)34 b(c)n(hanging)e(the)i(de\014nitions)g
+(of)515 922 y(an)n(y)f(of)h(these)g(v)-5 b(ariables)33
+b(y)n(ou)g(should)h(do)f Fg(make)42 b(scheme48vm)30 b
+Fj(to)k(rebuild)g(the)h(virtual)515 1021 y(mac)n(hine.)515
+1296 y Fk(5)134 b(Dynamic)46 b(Loading)515 1478 y Fj(External)23
+b(co)r(de)g(can)h(b)r(e)g(loaded)g(in)n(to)g(a)f(running)h(Sc)n(heme)g
+(48)f(pro)r(cess)g(and)g(C)i(ob)5 b(ject-\014le)515 1577
+y(bindings)30 b(can)h(b)r(e)g(dereferenced)f(at)h(run)n(time)f(and)h
+(their)g(v)-5 b(alues)30 b(called)h(\(although)f(not)515
+1677 y(all)f(v)n(ersions)f(of)i(Unix)g(supp)r(ort)g(all)f(of)h(this\).)
+44 b(The)30 b(required)f(Sc)n(heme)h(functions)g(are)f(in)515
+1776 y(the)f(structure)f Fg(dynamic-external)o(s)p Fj(.)531
+1926 y Fi(\017)41 b Fg(\(dynamic-load)36 b Ff(string)7
+b Fg(\))515 2075 y(Dynamic-load)15 b Fj(loads)k(the)h(named)g(\014le)g
+(in)n(to)g(the)g(curren)n(t)f(pro)r(cess,)h(raising)f(an)g(exception)
+515 2175 y(if)g(the)g(\014le)g(cannot)f(b)r(e)h(found)g(or)f(if)h
+(dynamic)g(loading)f(is)g(not)h(supp)r(orted)g(b)n(y)f(the)h(op)r
+(erating)515 2275 y(system.)36 b(The)26 b(\014le)f(m)n(ust)h(ha)n(v)n
+(e)f(b)r(een)h(compiled)g(and)f(link)n(ed)h(appropriately)-7
+b(.)34 b(F)-7 b(or)25 b(Lin)n(ux,)515 2374 y(the)33 b(follo)n(wing)g
+(commands)f(compile)i Fg(foo.c)d Fj(in)n(to)i(a)g(\014le)g
+Fg(foo.so)e Fj(that)j(can)f(b)r(e)h(loaded)515 2474 y(dynamically)-7
+b(.)680 2640 y Fg(\045)43 b(gcc)g(-c)f(-o)h(foo.o)f(foo.c)680
+2739 y(\045)h(ld)g(-shared)e(-o)h(foo.so)g(foo.o)531
+2906 y Fi(\017)f Fg(\(get-external)36 b Ff(string)7 b
+Fg(\))42 b Fi(!)f Ff(external)531 3005 y Fi(\017)g Fg(\(external?)46
+b Ff(x)10 b Fg(\))41 b Fi(!)g Ff(b)l(o)l(ole)l(an)531
+3105 y Fi(\017)g Fg(\(external-name)36 b Ff(external)9
+b Fg(\))41 b Fi(!)g Ff(string)531 3204 y Fi(\017)g Fg(\(external-value)
+36 b Ff(external)9 b Fg(\))40 b Fi(!)i Ff(byte-ve)l(ctor)515
+3354 y Fj(These)c(functions)g(giv)n(e)g(access)f(to)h(v)-5
+b(alues)38 b(b)r(ound)h(in)g(the)f(curren)n(t)g(pro)r(cess,)i(and)e
+(are)515 3453 y(used)26 b(for)g(retrieving)f(v)-5 b(alues)26
+b(from)g(dynamically-loaded)e(\014les.)36 b Fg(Get-external)22
+b Fj(returns)515 3553 y(an)41 b Ff(external)49 b Fj(ob)5
+b(ject)41 b(that)h(con)n(tains)e(the)i(v)-5 b(alue)41
+b(of)g Ff(name)p Fj(,)k(raising)40 b(an)h(exception)g(if)515
+3653 y(there)f(is)h(no)g(suc)n(h)f(v)-5 b(alue)41 b(in)g(the)h(curren)n
+(t)e(pro)r(cess.)75 b Fg(External?)f Fj(is)40 b(the)i(predicate)515
+3752 y(for)33 b(externals,)g(and)h Fg(external-name)28
+b Fj(and)33 b Fg(external-value)27 b Fj(return)33 b(the)h(name)f(and)
+515 3852 y(v)-5 b(alue)34 b(of)g(an)g(external.)55 b(The)34
+b(v)-5 b(alue)34 b(is)g(returned)g(as)f(b)n(yte)h(v)n(ector)f(of)h
+(length)g(four)g(\(on)515 3952 y(32-bit)29 b(arc)n(hitectures\).)41
+b(The)30 b(v)-5 b(alue)29 b(is)h(that)g(whic)n(h)f(w)n(as)g(extan)n(t)g
+(when)h Fg(get-external)515 4051 y Fj(w)n(as)k(called.)58
+b(The)35 b(follo)n(wing)f(t)n(w)n(o)g(functions)h(can)f(b)r(e)i(used)e
+(to)h(up)r(date)g(the)h(v)-5 b(alues)34 b(of)515 4151
+y(externals.)531 4300 y Fi(\017)41 b Fg(\(lookup-external)35
+b Ff(external)9 b Fg(\))41 b Fi(!)g Ff(b)l(o)l(ole)l(an)531
+4400 y Fi(\017)g Fg(\(lookup-all-exter)o(na)o(ls\))35
+b Fi(!)41 b Ff(b)l(o)l(ole)l(an)515 4549 y Fg(Lookup-external)19
+b Fj(up)r(dates)26 b(the)g(v)-5 b(alue)26 b(of)g Ff(external)f
+Fj(b)n(y)h(lo)r(oking)e(its)i(name)g(in)g(the)g(cur-)515
+4649 y(ren)n(t)18 b(pro)r(cess,)h(returning)g Fg(#t)e
+Fj(if)i(it)g(is)f(b)r(ound)h(and)f Fg(#f)g Fj(if)h(it)f(is)h(not.)33
+b Fg(Lookup-all-extern)o(als)515 4749 y Fj(calls)27 b
+Fg(lookup-external)21 b Fj(on)27 b(all)h(extan)n(t)f(externals,)g
+(returning)h Fg(#f)e Fj(an)n(y)h(are)g(un)n(b)r(ound.)531
+4898 y Fi(\017)41 b Fg(\(call-external)36 b Ff(external)41
+b(ar)l(g)1706 4910 y Fd(0)1786 4898 y Ff(.)13 b(.)g(.)g
+Fg(\))50 b Fi(!)42 b Ff(value)1926 5255 y Fj(5)p eop
+%%Page: 6 6
+6 5 bop 515 523 a Fj(An)29 b(external)f(whose)g(v)-5
+b(alue)29 b(is)f(a)g(C)h(pro)r(cedure)f(can)g(b)r(e)h(called)g(using)g
+Fg(call-external)p Fj(.)515 623 y(See)e(Section)h(3)55
+b(for)27 b(more)g(information.)639 722 y(In)e(some)f(v)n(ersions)f(of)h
+(Unix)h(retrieving)f(a)g(v)-5 b(alue)25 b(from)f(the)h(curren)n(t)f
+(pro)r(cess)f(ma)n(y)h(re-)515 822 y(quire)f(a)g(non-trivial)f(amoun)n
+(t)h(of)h(computation.)35 b(W)-7 b(e)24 b(recommend)f(that)h(a)f
+(dynamically-)515 922 y(loaded)i(\014le)g(con)n(tain)g(a)g(single)g
+(initialization)g(pro)r(cedure)g(that)g(creates)g(shared)f(bindings)515
+1021 y(for)j(the)h(v)-5 b(alues)27 b(exp)r(orted)g(b)n(y)g(the)h
+(\014le.)515 1296 y Fk(6)134 b(Compatibilit)l(y)515 1478
+y Fj(Sc)n(heme)18 b(48's)f(old)h Fg(external-call)c Fj(function)k(is)h
+(still)f(a)n(v)-5 b(ailable)17 b(in)i(the)g(structure)f
+Fg(externals)p Fj(,)515 1577 y(whic)n(h)g(no)n(w)g(also)f(includes)i
+Fg(external-name)13 b Fj(and)18 b Fg(external-value)p
+Fj(.)28 b(The)18 b(old)h Fg(scheme48.h)515 1677 y Fj(\014le)27
+b(has)h(b)r(een)g(renamed)f Fg(old-scheme48.h)p Fj(.)515
+1951 y Fk(7)134 b(Accessing)45 b(Sc)l(heme)g(data)h(from)f(C)515
+2133 y Fj(The)37 b(C)h(header)e(\014le)i Fg(scheme48.h)33
+b Fj(pro)n(vides)j(access)g(to)h(Sc)n(heme)h(48)e(data)h(structures)515
+2233 y(\(for)i(compatibilit)n(y)-7 b(,)42 b(the)e(old)g
+Fg(scheme48.h)35 b Fj(\014le)40 b(is)f(a)n(v)-5 b(ailable)39
+b(as)f Fg(old-scheme48.h)p Fj(\).)515 2332 y(The)d(t)n(yp)r(e)g
+Fg(s48)p 1024 2332 27 4 v 30 w(value)e Fj(is)h(used)h(for)g(Sc)n(heme)f
+(v)-5 b(alues.)59 b(When)35 b(the)g(t)n(yp)r(e)g(of)g(a)f(v)-5
+b(alue)35 b(is)515 2432 y(kno)n(wn,)24 b(suc)n(h)f(as)h(the)g(in)n
+(teger)f(returned)g(b)n(y)i Fg(vector-length)19 b Fj(or)k(the)h(b)r(o)r
+(olean)g(returned)515 2532 y(b)n(y)29 b Fg(pair?)p Fj(,)e(the)i
+(corresp)r(onding)e(C)i(pro)r(cedure)f(returns)g(a)g(C)h(v)-5
+b(alue)28 b(of)h(the)g(appropriate)515 2631 y(t)n(yp)r(e,)f(and)f(not)h
+(a)f Fg(s48)p 1240 2631 V 30 w(value)p Fj(.)35 b(Predicates)26
+b(return)h Fg(1)g Fj(for)g(true)h(and)f Fg(0)h Fj(for)f(false.)515
+2864 y Fh(7.1)112 b(Constan)m(ts)515 3017 y Fj(The)27
+b(follo)n(wing)g(macros)f(denote)h(Sc)n(heme)h(constan)n(ts:)515
+3183 y Fg(S48)p 652 3183 V 30 w(FALSE)39 b Fj(is)28 b
+Fg(#f)p Fj(.)515 3349 y Fg(S48)p 652 3349 V 30 w(TRUE)40
+b Fj(is)27 b Fg(#t)p Fj(.)515 3515 y Fg(S48)p 652 3515
+V 30 w(NULL)40 b Fj(is)27 b(the)h(empt)n(y)g(list.)515
+3681 y Fg(S48)p 652 3681 V 30 w(UNSPECIFIC)37 b Fj(is)26
+b(a)g(v)-5 b(alue)26 b(used)g(for)g(functions)g(whic)n(h)g(ha)n(v)n(e)f
+(no)h(meaningful)h(return)722 3781 y(v)-5 b(alue)22 b(\(in)g(Sc)n(heme)
+g(this)g(v)-5 b(alue)21 b(returned)g(b)n(y)h(the)g(n)n(ullary)e(pro)r
+(cedure)h Fg(unspecific)722 3880 y Fj(in)28 b(the)g(structure)f
+Fg(util)p Fj(\).)515 4046 y Fg(S48)p 652 4046 V 30 w(EOF)40
+b Fj(is)22 b(the)g(end-of-\014le)f(ob)5 b(ject)22 b(\(in)h(Sc)n(heme)e
+(this)h(v)-5 b(alue)22 b(is)g(returned)f(b)n(y)h(the)g(n)n(ullary)722
+4146 y(pro)r(cedure)27 b Fg(eof-object)c Fj(in)28 b(the)g(structure)f
+Fg(i/o-internal)p Fj(\).)515 4378 y Fh(7.2)112 b(Con)m(v)m(erting)37
+b(v)-6 b(alues)515 4532 y Fj(The)28 b(follo)n(wing)f(functions)i(con)n
+(v)n(ert)e(v)-5 b(alues)28 b(b)r(et)n(w)n(een)g(Sc)n(heme)g(and)h(C)f
+(represen)n(tations.)515 4631 y(The)e(`extract')g(ones)f(con)n(v)n(ert)
+g(from)h(Sc)n(heme)g(to)h(C)f(and)g(the)h(`en)n(ter's)e(go)h(the)g
+(other)g(w)n(a)n(y)-7 b(.)531 4781 y Fi(\017)41 b Fg(unsigned)e(char)g
+(s48)p 1357 4781 V 31 w(extract)p 1696 4781 V 28 w(char\(s48)p
+2076 4781 V 28 w(value\))531 4880 y Fi(\017)i Fg(char)f(*)166
+b(s48)p 1177 4880 V 30 w(extract)p 1515 4880 V 28 w(string\(s48)p
+1983 4880 V 28 w(value\))531 4980 y Fi(\017)41 b Fg(long)248
+b(s48)p 1175 4980 V 30 w(extract)p 1513 4980 V 28 w(integer\(s48)p
+2025 4980 V 27 w(value\))1926 5255 y Fj(6)p eop
+%%Page: 7 7
+7 6 bop 531 523 a Fi(\017)41 b Fg(double)164 b(s48)p
+1179 523 27 4 v 30 w(extract)p 1517 523 V 29 w(double\(s48)p
+1986 523 V 27 w(value\))531 623 y Fi(\017)41 b Fg(s48)p
+751 623 V 31 w(value)e(s48)p 1173 623 V 30 w(enter)p
+1423 623 V 29 w(char\(unsigned)e(char\))531 722 y Fi(\017)k
+Fg(s48)p 751 722 V 31 w(value)e(s48)p 1173 722 V 30 w(enter)p
+1423 722 V 29 w(string\(char)e(*\))953 b Fj(\(ma)n(y)28
+b(GC\))531 822 y Fi(\017)41 b Fg(s48)p 751 822 V 31 w(value)e(s48)p
+1173 822 V 30 w(enter)p 1423 822 V 29 w(integer\(long\))990
+b Fj(\(ma)n(y)28 b(GC\))531 922 y Fi(\017)41 b Fg(s48)p
+751 922 V 31 w(value)e(s48)p 1173 922 V 30 w(enter)p
+1423 922 V 29 w(double\(double\))946 b Fj(\(ma)n(y)28
+b(GC\))515 1066 y(The)k(v)-5 b(alue)32 b(returned)g(b)n(y)h
+Fg(s48)p 1509 1066 V 30 w(extract)p 1847 1066 V 29 w(string)c
+Fj(p)r(oin)n(ts)j(to)h(the)f(actual)g(storage)e(used)515
+1165 y(b)n(y)d(the)h(string;)f(it)h(is)g(v)-5 b(alid)27
+b(only)g(un)n(til)h(the)g(next)g(garbage)d(collection;)i(see)h(Section)
+f(9.)639 1265 y Fg(s48)p 776 1265 V 30 w(enter)p 1026
+1265 V 30 w(integer\(\))33 b Fj(needs)j(to)h(allo)r(cate)f(storage)e
+(when)j(its)g(argumen)n(t)f(is)g(to)r(o)515 1365 y(large)28
+b(to)j(\014t)f(in)h(a)e(Sc)n(heme)h(48)g(\014xn)n(um.)44
+b(In)31 b(cases)e(where)h(the)g(n)n(um)n(b)r(er)g(is)g(kno)n(wn)g(to)g
+(\014t)515 1464 y(within)d(a)f(\014xn)n(um)g(\(curren)n(tly)g(30)f
+(bits)i(including)f(the)h(sign\),)f(the)h(follo)n(wing)e(pro)r(cedures)
+515 1564 y(can)30 b(b)r(e)g(used.)45 b(These)30 b(ha)n(v)n(e)f(the)h
+(disadv)-5 b(an)n(tage)29 b(of)h(only)g(ha)n(ving)f(a)h(limited)h
+(range,)e(but)515 1664 y(the)f(adv)-5 b(an)n(tage)26
+b(of)h(nev)n(er)g(causing)g(a)g(garbage)e(collection.)531
+1808 y Fi(\017)41 b Fg(long)248 b(s48)p 1175 1808 V 30
+w(extract)p 1513 1808 V 28 w(fixnum\(s48)p 1981 1808
+V 28 w(value\))531 1908 y Fi(\017)41 b Fg(s48)p 751 1908
+V 31 w(value)e(s48)p 1173 1908 V 30 w(enter)p 1423 1908
+V 29 w(fixnum\(long\))531 2007 y Fi(\017)i Fg(long)248
+b(S48)p 1175 2007 V 30 w(MAX)p 1337 2007 V 30 w(FIXNUM)p
+1631 2007 V 29 w(VALUE)531 2107 y Fi(\017)41 b Fg(long)248
+b(S48)p 1175 2107 V 30 w(MIN)p 1337 2107 V 30 w(FIXNUM)p
+1631 2107 V 29 w(VALUE)515 2251 y Fj(An)23 b(error)d(is)i(signalled)g
+(if)29 b Fg(s48)p 1473 2251 V 30 w(extract)p 1811 2251
+V 29 w(fixnum)p Fj('s)19 b(argumen)n(t)j(is)g(not)g(a)g(\014xn)n(um)g
+(or)g(if)h(the)515 2351 y(argumen)n(t)31 b(to)i Fg(s48)p
+1135 2351 V 30 w(enter)p 1385 2351 V 30 w(fixnum)d Fj(is)j(less)f(than)
+h Fg(S48)p 2287 2351 V 30 w(MIN)p 2449 2351 V 30 w(FIXNUM)p
+2743 2351 V 29 w(VALUE)e Fj(or)h(greater)515 2450 y(than)27
+b Fg(S48)p 845 2450 V 31 w(MAX)p 1008 2450 V 30 w(FIXNUM)p
+1302 2450 V 29 w(VALUE)e Fj(\()p Fi(\000)p Fj(2)1710
+2420 y Fd(29)1808 2450 y Fj(and)i(2)2011 2420 y Fd(29)2099
+2450 y Fi(\000)18 b Fj(1)28 b(in)f(the)h(curren)n(t)f(system\).)515
+2682 y Fh(7.3)112 b(C)37 b(v)m(ersions)h(of)f(Sc)m(heme)g(pro)s
+(cedures)515 2835 y Fj(The)23 b(follo)n(wing)f(macros)g(and)h(pro)r
+(cedures)f(are)g(C)h(v)n(ersions)f(of)h(Sc)n(heme)g(pro)r(cedures.)34
+b(The)515 2935 y(names)27 b(w)n(ere)g(deriv)n(ed)f(b)n(y)i(replacing)e
+(`)p Fg(-)p Fj(')h(with)i(`)p 2057 2935 V 31 w(',)f(`)p
+Fg(?)p Fj(')36 b(with)28 b(`)p Fg(p)p Fj(',)g(and)f(dropping)g(`)p
+Fg(!)p Fj(.)531 3079 y Fi(\017)41 b Fg(int)290 b(S48)p
+1173 3079 V 30 w(EQ)p 1291 3079 V 30 w(P\(s48)p 1541
+3079 V 30 w(value\))531 3179 y Fi(\017)41 b Fg(int)290
+b(S48)p 1173 3179 V 30 w(CHAR)p 1379 3179 V 30 w(P\(s48)p
+1629 3179 V 29 w(value\))531 3278 y Fi(\017)41 b Fg(int)290
+b(S48)p 1173 3278 V 30 w(INTEGER)p 1511 3278 V 28 w(P\(s48)p
+1759 3278 V 30 w(value\))531 3422 y Fi(\017)41 b Fg(int)290
+b(S48)p 1173 3422 V 30 w(PAIR)p 1379 3422 V 30 w(P\(s48)p
+1629 3422 V 29 w(value\))531 3522 y Fi(\017)41 b Fg(s48)p
+751 3522 V 31 w(value)e(S48)p 1173 3522 V 30 w(CAR\(s48)p
+1511 3522 V 29 w(value\))531 3622 y Fi(\017)i Fg(s48)p
+751 3622 V 31 w(value)e(S48)p 1173 3622 V 30 w(CDR\(s48)p
+1511 3622 V 29 w(value\))531 3721 y Fi(\017)i Fg(void)248
+b(S48)p 1175 3721 V 30 w(SET)p 1337 3721 V 30 w(CAR\(s48)p
+1675 3721 V 29 w(value,)39 b(s48)p 2139 3721 V 30 w(value\))531
+3821 y Fi(\017)i Fg(void)248 b(S48)p 1175 3821 V 30 w(SET)p
+1337 3821 V 30 w(CDR\(s48)p 1675 3821 V 29 w(value,)39
+b(s48)p 2139 3821 V 30 w(value\))531 3921 y Fi(\017)i
+Fg(s48)p 751 3921 V 31 w(value)e(s48)p 1173 3921 V 30
+w(cons\(s48)p 1555 3921 V 28 w(value,)g(s48)p 2018 3921
+V 30 w(value\))702 b Fj(\(ma)n(y)28 b(GC\))531 4020 y
+Fi(\017)41 b Fg(long)248 b(s48)p 1175 4020 V 30 w(length\(s48)p
+1645 4020 V 27 w(value\))531 4165 y Fi(\017)41 b Fg(int)290
+b(S48)p 1173 4165 V 30 w(VECTOR)p 1467 4165 V 29 w(P\(s48)p
+1716 4165 V 29 w(value\))531 4264 y Fi(\017)41 b Fg(long)248
+b(S48)p 1175 4264 V 30 w(VECTOR)p 1469 4264 V 29 w(LENGTH\(s48)p
+1938 4264 V 27 w(value\))531 4364 y Fi(\017)41 b Fg(s48)p
+751 4364 V 31 w(value)e(S48)p 1173 4364 V 30 w(VECTOR)p
+1467 4364 V 29 w(REF\(s48)p 1804 4364 V 28 w(value,)g(long\))531
+4463 y Fi(\017)i Fg(void)248 b(S48)p 1175 4463 V 30 w(VECTOR)p
+1469 4463 V 29 w(SET\(s48)p 1806 4463 V 28 w(value,)39
+b(long,)h(s48)p 2529 4463 V 30 w(value\))531 4563 y Fi(\017)h
+Fg(s48)p 751 4563 V 31 w(value)e(s48)p 1173 4563 V 30
+w(make)p 1379 4563 V 30 w(vector\(long,)d(s48)p 2105
+4563 V 30 w(value\))615 b Fj(\(ma)n(y)28 b(GC\))531 4707
+y Fi(\017)41 b Fg(int)290 b(S48)p 1173 4707 V 30 w(STRING)p
+1467 4707 V 29 w(P\(s48)p 1716 4707 V 29 w(value\))531
+4807 y Fi(\017)41 b Fg(long)248 b(S48)p 1175 4807 V 30
+w(STRING)p 1469 4807 V 29 w(LENGTH\(s48)p 1938 4807 V
+27 w(value\))531 4907 y Fi(\017)41 b Fg(char)248 b(S48)p
+1175 4907 V 30 w(STRING)p 1469 4907 V 29 w(REF\(s48)p
+1806 4907 V 28 w(value,)39 b(long\))531 5006 y Fi(\017)i
+Fg(void)248 b(S48)p 1175 5006 V 30 w(STRING)p 1469 5006
+V 29 w(SET\(s48)p 1806 5006 V 28 w(value,)39 b(long,)h(char\))1926
+5255 y Fj(7)p eop
+%%Page: 8 8
+8 7 bop 531 523 a Fi(\017)41 b Fg(s48)p 751 523 27 4
+v 31 w(value)e(s48)p 1173 523 V 30 w(make)p 1379 523
+V 30 w(string\(long,)d(char\))821 b Fj(\(ma)n(y)28 b(GC\))531
+672 y Fi(\017)41 b Fg(int)290 b(S48)p 1173 672 V 30 w(SYMBOL)p
+1467 672 V 29 w(P\(s48)p 1716 672 V 29 w(value\))531
+772 y Fi(\017)41 b Fg(s48)p 751 772 V 31 w(value)e(s48)p
+1173 772 V 30 w(SYMBOL)p 1467 772 V 29 w(TO)p 1584 772
+V 31 w(STRING\(s48)p 2055 772 V 27 w(value\))531 922
+y Fi(\017)i Fg(int)290 b(S48)p 1173 922 V 30 w(BYTE)p
+1379 922 V 30 w(VECTOR)p 1673 922 V 28 w(P\(s48)p 1921
+922 V 30 w(value\))531 1021 y Fi(\017)41 b Fg(long)248
+b(S48)p 1175 1021 V 30 w(BYTE)p 1381 1021 V 30 w(VECTOR)p
+1675 1021 V 29 w(LENGTH\(s48)p 2144 1021 V 27 w(value\))531
+1121 y Fi(\017)41 b Fg(char)248 b(S48)p 1175 1121 V 30
+w(BYTE)p 1381 1121 V 30 w(VECTOR)p 1675 1121 V 29 w(REF\(s48)p
+2012 1121 V 28 w(value,)39 b(long\))531 1220 y Fi(\017)i
+Fg(void)248 b(S48)p 1175 1220 V 30 w(BYTE)p 1381 1220
+V 30 w(VECTOR)p 1675 1220 V 29 w(SET\(s48)p 2012 1220
+V 28 w(value,)39 b(long,)g(int\))531 1320 y Fi(\017)i
+Fg(s48)p 751 1320 V 31 w(value)e(s48)p 1173 1320 V 30
+w(make)p 1379 1320 V 30 w(byte)p 1585 1320 V 30 w(vector\(long,)d
+(int\))659 b Fj(\(ma)n(y)28 b(GC\))515 1595 y Fk(8)134
+b(Calling)47 b(Sc)l(heme)e(functions)g(from)g(C)515 1776
+y Fj(External)29 b(co)r(de)h(that)g(has)g(b)r(een)h(called)f(from)g(Sc)
+n(heme)g(can)g(call)g(bac)n(k)f(to)h(Sc)n(heme)g(pro-)515
+1876 y(cedures)d(using)g(the)h(follo)n(wing)e(function.)531
+2026 y Fi(\017)41 b Fg(scheme)p 883 2026 V 29 w(value)f(s48)p
+1304 2026 V 30 w(call)p 1510 2026 V 30 w(scheme\(s48)p
+1980 2026 V 27 w(value)f(proc,)h(long)g(nargs,)f(...\))515
+2175 y Fj(This)33 b(calls)f(the)i(Sc)n(heme)e(pro)r(cedure)g
+Fg(proc)g Fj(on)h Fg(nargs)e Fj(argumen)n(ts,)i(whic)n(h)g(are)f
+(passed)515 2275 y(as)i(additional)g(argumen)n(ts)f(to)i
+Fg(s48)p 1680 2275 V 30 w(call)p 1886 2275 V 30 w(scheme)p
+Fj(.)56 b(There)34 b(ma)n(y)g(b)r(e)h(at)g(most)f(ten)h(ar-)515
+2374 y(gumen)n(ts.)58 b(The)34 b(v)-5 b(alue)35 b(returned)f(b)n(y)g
+(the)i(Sc)n(heme)e(pro)r(cedure)g(is)g(returned)h(b)n(y)f(the)h(C)515
+2474 y(pro)r(cedure.)62 b(In)n(v)n(oking)35 b(an)n(y)h(Sc)n(heme)g(pro)
+r(cedure)g(ma)n(y)f(p)r(oten)n(tially)i(cause)e(a)h(garbage)515
+2573 y(collection.)639 2673 y(There)19 b(are)f(some)g(complications)g
+(that)h(o)r(ccur)g(when)g(mixing)f(calls)h(from)f(C)h(to)g(Sc)n(heme)
+515 2773 y(with)29 b(con)n(tin)n(uations)f(and)h(threads.)40
+b(C)29 b(only)g(supp)r(orts)f(do)n(wn)n(w)n(ard)f(con)n(tin)n(uations)h
+(\(via)515 2872 y Fg(longjmp\(\))p Fj(\).)39 b(Sc)n(heme)30
+b(con)n(tin)n(uations)e(that)i(capture)f(a)g(p)r(ortion)g(of)h(the)g(C)
+g(stac)n(k)e(ha)n(v)n(e)515 2972 y(to)40 b(follo)n(w)h(the)g(same)f
+(restriction.)76 b(F)-7 b(or)40 b(example,)k(supp)r(ose)c(Sc)n(heme)h
+(pro)r(cedure)f Fg(s0)515 3072 y Fj(captures)f(con)n(tin)n(uation)h
+Fg(a)g Fj(and)g(then)h(calls)f(C)h(pro)r(cedure)e Fg(c0)p
+Fj(,)k(whic)n(h)d(in)h(turn)g(calls)515 3171 y(Sc)n(heme)26
+b(pro)r(cedure)g Fg(s1)p Fj(.)36 b(Pro)r(cedure)25 b
+Fg(s1)h Fj(can)g(safely)h(call)f(the)h(con)n(tin)n(uation)f
+Fg(a)p Fj(,)g(b)r(ecause)515 3271 y(that)32 b(is)g(a)g(do)n(wn)n(w)n
+(ard)e(use.)50 b(When)33 b Fg(a)e Fj(is)h(called)g(Sc)n(heme)g(48)f
+(will)i(remo)n(v)n(e)d(the)j(p)r(ortion)515 3370 y(of)j(the)i(C)f(stac)
+n(k)e(used)i(b)n(y)g(the)g(call)f(to)h Fg(c0)p Fj(.)64
+b(On)36 b(the)h(other)g(hand,)i(if)k Fg(s1)37 b Fj(captures)e(a)515
+3470 y(con)n(tin)n(uation,)f(that)f(con)n(tin)n(uation)g(cannot)g(b)r
+(e)g(used)h(from)f Fg(s0)p Fj(,)h(b)r(ecause)f(b)n(y)g(the)h(time)515
+3570 y(con)n(trol)21 b(returns)h(to)g Fg(s0)g Fj(the)h(C)g(stac)n(k)f
+(used)g(b)n(y)i Fg(c0)e Fj(will)g(no)h(longer)e(b)r(e)i(v)-5
+b(alid.)35 b(An)23 b(attempt)515 3669 y(to)31 b(in)n(v)n(ok)n(e)f(an)i
+(up)n(w)n(ard)e(con)n(tin)n(uation)h(that)h(is)g(closed)f(o)n(v)n(er)f
+(a)h(p)r(ortion)g(of)h(the)g(C)g(stac)n(k)515 3769 y(will)c(raise)e(an)
+h(exception.)639 3869 y(In)22 b(Sc)n(heme)f(48)f(threads)h(are)f
+(implemen)n(ted)i(using)f(con)n(tin)n(uations,)g(so)f(the)i(do)n(wn)n
+(w)n(ard)515 3968 y(restriction)27 b(applies)g(to)h(them)h(as)e(w)n
+(ell.)38 b(An)29 b(attempt)f(to)g(return)g(from)f(Sc)n(heme)h(to)g(C)g
+(at)515 4068 y(a)33 b(time)h(when)g(the)f(appropriate)f(C)i(frame)f(is)
+g(not)h(on)f(top)h(of)f(the)h(C)g(stac)n(k)e(will)i(cause)515
+4167 y(the)c(curren)n(t)g(thread)g(to)g(blo)r(c)n(k)f(un)n(til)i(the)g
+(frame)f(is)g(a)n(v)-5 b(ailable.)43 b(F)-7 b(or)30 b(example,)g(supp)r
+(ose)515 4267 y(thread)21 b Fg(t0)f Fj(calls)h(a)g(C)g(pro)r(cedure)f
+(whic)n(h)i(calls)e(bac)n(k)h(to)g(Sc)n(heme,)h(at)g(whic)n(h)f(p)r
+(oin)n(t)g(con)n(trol)515 4367 y(switc)n(hes)g(to)g(thread)g
+Fg(t1)p Fj(,)h(whic)n(h)f(also)g(calls)f(C)i(and)f(then)h(bac)n(k)e(to)
+i(Sc)n(heme.)34 b(A)n(t)22 b(this)g(p)r(oin)n(t)515 4466
+y(b)r(oth)28 b Fg(t0)f Fj(and)g Fg(t1)g Fj(ha)n(v)n(e)g(activ)n(e)g
+(calls)g(to)h(C)f(on)h(the)g(C)g(stac)n(k,)e(with)j Fg(t1)p
+Fj('s)d(C)i(frame)f(ab)r(o)n(v)n(e)515 4566 y Fg(t0)p
+Fj('s.)60 b(If)36 b(thread)f Fg(t0)g Fj(attempts)h(to)g(return)f(from)g
+(Sc)n(heme)h(to)f(C)h(it)g(will)g(blo)r(c)n(k,)h(as)e(its)515
+4666 y(frame)27 b(is)h(not)h(accessable.)37 b(Once)27
+b Fg(t1)h Fj(has)f(returned)h(to)g(C)g(and)g(from)g(there)g(to)g(Sc)n
+(heme,)515 4765 y Fg(t0)k Fj(will)h(b)r(e)h(able)e(to)h(resume.)53
+b(The)33 b(return)f(to)h(Sc)n(heme)g(is)g(required)f(b)r(ecause)g(con)n
+(text)515 4865 y(switc)n(hes)25 b(can)h(only)f(o)r(ccur)h(while)g(C)g
+(co)r(de)g(is)f(running.)36 b Fg(T0)26 b Fj(will)g(also)f(b)r(e)h(able)
+g(to)g(resume)515 4964 y(if)34 b Fg(t1)27 b Fj(uses)g(a)h(con)n(tin)n
+(uation)e(to)i(thro)n(w)e(past)i(its)g(call)f(to)g(C.)1926
+5255 y(8)p eop
+%%Page: 9 9
+9 8 bop 515 523 a Fk(9)134 b(In)l(teracting)47 b(with)e(the)g(Sc)l
+(heme)g(Heap)515 705 y Fj(Sc)n(heme)35 b(48)f(uses)h(a)g(cop)n(ying,)h
+(precise)e(garbage)f(collector.)59 b(An)n(y)35 b(pro)r(cedure)f(that)i
+(al-)515 805 y(lo)r(cates)g(ob)5 b(jects)37 b(within)h(the)g(Sc)n(heme)
+f(48)f(heap)h(ma)n(y)g(trigger)f(a)h(garbage)e(collection.)515
+904 y(V)-7 b(ariables)23 b(b)r(ound)j(to)e(v)-5 b(alues)25
+b(in)g(the)g(Sc)n(heme)g(48)f(heap)g(need)h(to)g(b)r(e)g(registered)e
+(with)j(the)515 1004 y(garbage)20 b(collector)h(so)h(that)h(the)g(v)-5
+b(alue)23 b(will)g(b)r(e)g(retained)f(and)h(so)f(that)g(the)h(v)-5
+b(ariables)22 b(will)515 1103 y(b)r(e)i(up)r(dated)h(if)f(the)h
+(garbage)c(collector)i(mo)n(v)n(es)f(the)j(ob)5 b(ject.)35
+b(The)24 b(garbage)e(collector)h(has)515 1203 y(no)i(facilit)n(y)g(for)
+g(up)r(dating)h(p)r(oin)n(ters)f(to)g(the)h(in)n(teriors)e(of)h(ob)5
+b(jects,)25 b(so)g(suc)n(h)g(p)r(oin)n(ters,)h(for)515
+1303 y(example)f(the)h(ones)e(returned)i(b)n(y)g Fg(EXTRACT)p
+1924 1303 27 4 v 28 w(STRING)p Fj(,)d(will)j(lik)n(ely)f(b)r(ecome)g
+(in)n(v)-5 b(alid)26 b(when)515 1402 y(a)h(garbage)e(collection)i(o)r
+(ccurs.)515 1634 y Fh(9.1)112 b(Registering)35 b(Ob)6
+b(jects)38 b(with)f(the)g(GC)515 1788 y Fj(A)28 b(set)g(of)h(macros)d
+(are)h(used)i(to)f(manage)f(the)h(registration)e(of)j(lo)r(cal)e(v)-5
+b(ariables)27 b(with)i(the)515 1887 y(garbage)c(collector.)531
+2035 y Fi(\017)41 b Fg(S48)p 751 2035 V 31 w(DECLARE)p
+1090 2035 V 28 w(GC)p 1206 2035 V 31 w(PROTECT\()p Fa(n)p
+Fg(\))531 2135 y Fi(\017)g Fg(void)f(S48)p 967 2135 V
+30 w(GC)p 1085 2135 V 31 w(PROTECT)p 1424 2135 V 28 w
+Fa(n)p Fg(\(s48)p 1678 2135 V 30 w(value)1923 2147 y
+Fd(1)1958 2135 y Fg(,)h Fa(:)14 b(:)g(:)p Fg(,)41 b(s48)p
+2362 2135 V 30 w(value)2607 2147 y Fc(n)2650 2135 y Fg(\))531
+2235 y Fi(\017)g Fg(void)f(S48)p 967 2235 V 30 w(GC)p
+1085 2235 V 31 w(UNPROTECT\(\))639 2383 y(S48)p 776 2383
+V 30 w(DECLARE)p 1114 2383 V 29 w(GC)p 1231 2383 V 30
+w(PROTECT\()p Fa(n)p Fg(\))p Fj(,)28 b(where)i(1)d Fi(\024)g
+Fa(n)h Fi(\024)f Fj(9,)k(allo)r(cates)e(storage)g(for)h(regis-)515
+2483 y(tering)23 b Fa(n)h Fj(v)-5 b(ariables.)34 b(A)n(t)24
+b(most)g(one)g(use)f(of)31 b Fg(S48)p 2039 2483 V 30
+w(DECLARE)p 2377 2483 V 28 w(GC)p 2493 2483 V 31 w(PROTECT)21
+b Fj(ma)n(y)i(o)r(ccur)g(in)h(a)515 2582 y(blo)r(c)n(k.)35
+b Fg(S48)p 902 2582 V 30 w(GC)p 1020 2582 V 31 w(PROTECT)p
+1359 2582 V 28 w Fa(n)p Fg(\()p Fa(v)1516 2594 y Fd(1)1553
+2582 y Fg(,)43 b Fa(:)14 b(:)g(:)p Fg(,)43 b Fa(v)1864
+2594 y Fc(n)1910 2582 y Fg(\))24 b Fj(registers)e(the)j
+Fa(n)f Fj(v)-5 b(ariables)23 b(\(l-v)-5 b(alues\))25
+b(with)515 2682 y(the)c(garbage)d(collector.)33 b(It)21
+b(m)n(ust)f(b)r(e)h(within)g(scop)r(e)f(of)h(a)f Fg(S48)p
+2457 2682 V 30 w(DECLARE)p 2795 2682 V 28 w(GC)p 2911
+2682 V 31 w(PROTECT\()p Fa(n)p Fg(\))515 2781 y Fj(and)27
+b(b)r(e)i(b)r(efore)e(an)n(y)g(co)r(de)h(whic)n(h)g(can)f(cause)g(a)h
+(GC.)g Fg(S48)p 2383 2781 V 30 w(GC)p 2501 2781 V 31
+w(UNPROTECT)c Fj(remo)n(v)n(es)i(the)515 2881 y(blo)r(c)n(k's)32
+b(protected)h(v)-5 b(ariables)32 b(from)h(the)h(garbage)d(collectors)h
+(list.)54 b(It)34 b(m)n(ust)g(b)r(e)f(called)515 2981
+y(at)g(the)h(end)f(of)g(the)h(blo)r(c)n(k)f(after)g(an)n(y)f(co)r(de)h
+(whic)n(h)h(ma)n(y)e(cause)h(a)g(garbage)e(collection.)515
+3080 y(Omitting)d(an)n(y)f(of)g(the)h(three)g(ma)n(y)f(cause)g(serious)
+f(and)i(hard-to-debug)e(problems.)37 b(No-)515 3180 y(tably)-7
+b(,)36 b(the)f(garbage)d(collector)h(ma)n(y)h(relo)r(cate)g(an)g(ob)5
+b(ject)34 b(and)h(in)n(v)-5 b(alidate)34 b Fg(s48)p 3136
+3180 V 30 w(value)515 3280 y Fj(v)-5 b(ariables)26 b(whic)n(h)i(are)e
+(not)i(protected.)639 3379 y(A)h Fg(gc-protection-mis)o(mat)o(ch)22
+b Fj(exception)29 b(is)f(raised)g(if,)i(when)f(a)f(C)h(pro)r(cedure)f
+(re-)515 3479 y(turns)h(to)g(Sc)n(heme,)h(the)g(calls)f(to)g
+Fg(S48)p 1732 3479 V 30 w(GC)p 1850 3479 V 31 w(PROTECT\(\))d
+Fj(ha)n(v)n(e)i(not)h(b)r(een)h(matc)n(hed)f(b)n(y)g(an)515
+3578 y(equal)e(n)n(um)n(b)r(er)g(of)h(calls)f(to)g Fg(S48)p
+1554 3578 V 30 w(GC)p 1672 3578 V 31 w(UNPROTECT\(\))p
+Fj(.)639 3678 y(Global)g(v)-5 b(ariables)27 b(ma)n(y)g(also)f(b)r(e)i
+(registered)e(with)i(the)g(garbage)e(collector.)531 3826
+y Fi(\017)41 b Fg(void)f(S48)p 967 3826 V 30 w(GC)p 1085
+3826 V 31 w(PROTECT)p 1424 3826 V 28 w(GLOBAL\()p Ff(value)p
+Fg(\))515 3975 y(S48)p 652 3975 V 30 w(GC)p 770 3975
+V 30 w(PROTECT)p 1108 3975 V 29 w(GLOBAL)34 b Fj(p)r(ermanen)n(tly)i
+(registers)f(the)i(v)-5 b(ariable)35 b Ff(value)j Fj(\(an)e(l-v)-5
+b(alue\))515 4074 y(with)28 b(the)g(garbage)d(collector.)36
+b(There)27 b(is)g(no)h(w)n(a)n(y)e(to)h(unregister)g(the)h(v)-5
+b(ariable.)515 4306 y Fh(9.2)112 b(Keeping)37 b(C)g(data)i(structures)e
+(in)f(the)i(Sc)m(heme)f(heap)515 4460 y Fj(C)32 b(data)f(structures)h
+(can)f(b)r(e)i(k)n(ept)f(in)g(the)h(Sc)n(heme)f(heap)f(b)n(y)h(em)n(b)r
+(edding)g(them)h(inside)515 4559 y(b)n(yte)26 b(v)n(ectors.)35
+b(The)27 b(follo)n(wing)f(macros)f(can)h(b)r(e)h(used)g(to)g(create)f
+(and)g(access)g(em)n(b)r(edded)515 4659 y(C)h(ob)5 b(jects.)531
+4807 y Fi(\017)41 b Fg(s48)p 751 4807 V 31 w(value)e(S48)p
+1173 4807 V 30 w(MAKE)p 1379 4807 V 30 w(VALUE\(type\))1121
+b Fj(\(ma)n(y)28 b(GC\))531 4907 y Fi(\017)41 b Fg(type)248
+b(S48)p 1175 4907 V 30 w(EXTRACT)p 1513 4907 V 28 w(VALUE\(s48)p
+1937 4907 V 28 w(value,)39 b(type\))531 5006 y Fi(\017)i
+Fg(type)f(*)166 b(S48)p 1177 5006 V 30 w(EXTRACT)p 1515
+5006 V 28 w(VALUE)p 1763 5006 V 30 w(POINTER\(s48)p 2277
+5006 V 27 w(value,)39 b(type\))1926 5255 y Fj(9)p eop
+%%Page: 10 10
+10 9 bop 531 523 a Fi(\017)41 b Fg(void)248 b(S48)p 1175
+523 27 4 v 30 w(SET)p 1337 523 V 30 w(VALUE\(s48)p 1763
+523 V 28 w(value,)39 b(type,)g(value\))537 655 y(S48)p
+674 655 V 30 w(MAKE)p 880 655 V 29 w(VALUE)20 b Fj(mak)n(es)h(a)g(b)n
+(yte)h(v)n(ector)f(large)f(enough)h(to)h(hold)g(an)f(ob)5
+b(ject)22 b(whose)f(t)n(yp)r(e)515 755 y(is)30 b Ff(typ)l(e)p
+Fj(.)45 b Fg(S48)p 950 755 V 30 w(EXTRACT)p 1288 755
+V 29 w(VALUE)28 b Fj(returns)h(the)i(con)n(ten)n(ts)f(of)g(a)g(b)n(yte)
+g(v)n(ector)f(cast)h(to)g Ff(typ)l(e)p Fj(,)515 854 y(and)e
+Fg(S48)p 814 854 V 31 w(EXTRACT)p 1153 854 V 28 w(VALUE)p
+1401 854 V 29 w(POINTER)f Fj(returns)h(a)g(p)r(oin)n(ter)h(to)f(the)i
+(con)n(ten)n(ts)e(of)h(the)g(b)n(yte)515 954 y(v)n(ector.)43
+b(The)30 b(v)-5 b(alue)30 b(returned)g(b)n(y)h Fg(S48)p
+1790 954 V 30 w(EXTRACT)p 2128 954 V 29 w(VALUE)p 2377
+954 V 29 w(POINTER)d Fj(is)i(v)-5 b(alid)30 b(only)g(un)n(til)515
+1054 y(the)e(next)g(garbage)d(collection\(see)i(Section)g(9\).)639
+1153 y Fg(S48)p 776 1153 V 30 w(SET)p 938 1153 V 31 w(VALUE)e
+Fj(stores)i Fg(value)e Fj(in)n(to)i(the)h(b)n(yte)g(v)n(ector.)515
+1382 y Fh(9.3)112 b(C)37 b(co)s(de)h(and)g(heap)h(images)515
+1535 y Fj(Sc)n(heme)32 b(48)f(uses)g(dump)r(ed)i(heap)f(images)e(to)i
+(restore)f(a)g(previous)g(system)g(state.)50 b(The)515
+1635 y(Sc)n(heme)29 b(48)f(heap)h(is)g(written)g(in)n(to)g(a)f(\014le)i
+(in)f(a)f(mac)n(hine-indep)r(enden)n(t)i(and)e(op)r(erating-)515
+1734 y(system-indep)r(enden)n(t)34 b(format.)55 b(The)34
+b(pro)r(cedures)e(describ)r(ed)i(ab)r(o)n(v)n(e)e(ma)n(y)h(b)r(e)h
+(used)g(to)515 1834 y(create)26 b(ob)5 b(jects)28 b(in)g(the)g(Sc)n
+(heme)f(heap)h(that)f(con)n(tain)g(information)g(sp)r(eci\014c)h(to)g
+(the)g(cur-)515 1934 y(ren)n(t)40 b(mac)n(hine,)j(op)r(erating)c
+(system,)k(or)c(pro)r(cess.)74 b(A)41 b(heap)f(image)f(con)n(taining)g
+(suc)n(h)515 2033 y(ob)5 b(jects)27 b(ma)n(y)g(not)g(w)n(ork)g
+(correctly)f(on)h(when)h(resumed.)639 2133 y(T)-7 b(o)26
+b(address)f(this)h(problem,)g(a)g(record)f(t)n(yp)r(e)h(ma)n(y)f(b)r(e)
+i(giv)n(en)e(a)h(`resumer')f(pro)r(cedure.)515 2232 y(On)k(startup,)g
+(the)g(resumer)g(pro)r(cedure)f(for)g(a)h(t)n(yp)r(e)g(is)g(applied)h
+(to)f(eac)n(h)f(record)g(of)h(that)515 2332 y(t)n(yp)r(e)i(in)g(the)g
+(image)f(b)r(eing)h(restarted.)45 b(This)31 b(pro)r(cedure)f(can)h(up)r
+(date)g(the)g(record)e(in)i(a)515 2432 y(manner)19 b(appropriate)f(to)i
+(the)g(mac)n(hine,)h(op)r(erating)e(system,)i(or)e(pro)r(cess)f(used)i
+(to)g(resume)515 2531 y(the)28 b(image.)531 2663 y Fi(\017)41
+b Fg(\(define-record-re)o(su)o(mer)35 b Ff(r)l(e)l(c)l(or)l(d-typ)l(e)
+42 b(pr)l(o)l(c)l(e)l(dur)l(e)6 b Fg(\))515 2795 y(Define-record-re)o
+(su)o(me)o(r)19 b Fj(de\014nes)26 b Ff(pr)l(o)l(c)l(e)l(dur)l(e)p
+Fj(,)g(whic)n(h)f(should)g(accept)g(one)g(argumen)n(t,)515
+2895 y(to)30 b(b)r(e)i(the)f(resumer)e(for)i Ff(r)l(e)l(c)l(or)l(d-typ)
+l(e)6 b Fj(.)47 b(The)31 b(order)e(in)i(whic)n(h)g(resumer)f(pro)r
+(cedures)f(are)515 2995 y(called)e(is)g(not)h(sp)r(eci\014ed.)639
+3094 y(The)34 b Ff(pr)l(o)l(c)l(e)l(dur)l(e)f Fj(argumen)n(t)f(to)i
+Fg(define-record-r)o(esu)o(me)o(r)27 b Fj(ma)n(y)33 b(b)r(e)h
+Fg(#f)p Fj(,)g(in)f(whic)n(h)515 3194 y(case)22 b(records)f(of)h(the)h
+(giv)n(en)f(t)n(yp)r(e)h(are)f(not)h(written)g(out)f(in)h(heap)g
+(images.)34 b(When)23 b(writing)515 3293 y(a)37 b(heap)g(image)f(an)n
+(y)h(reference)f(to)h(suc)n(h)g(a)g(record)f(is)h(replaced)g(b)n(y)g
+(the)g(v)-5 b(alue)37 b(of)h(the)515 3393 y(record's)26
+b(\014rst)h(\014eld,)h(and)f(an)h(exception)f(is)g(raised)g(after)g
+(the)h(image)f(is)h(written.)515 3664 y Fk(10)135 b(Using)45
+b(Sc)l(heme)g(records)g(in)g(C)g(co)t(de)515 3846 y Fj(External)26
+b(mo)r(dules)i(can)f(create)g(records)f(and)h(access)f(their)i(slots)f
+(p)r(ositionally)-7 b(.)531 3978 y Fi(\017)41 b Fg(s48)p
+751 3978 V 31 w(value)e(S48)p 1173 3978 V 30 w(MAKE)p
+1379 3978 V 30 w(RECORD\(s48)p 1849 3978 V 27 w(value\))874
+b Fj(\(ma)n(y)28 b(GC\))531 4077 y Fi(\017)41 b Fg(int)290
+b(S48)p 1173 4077 V 30 w(RECORD)p 1467 4077 V 29 w(P\(s48)p
+1716 4077 V 29 w(value\))531 4177 y Fi(\017)41 b Fg(s48)p
+751 4177 V 31 w(value)e(S48)p 1173 4177 V 30 w(RECORD)p
+1467 4177 V 29 w(TYPE\(s48)p 1848 4177 V 28 w(value\))531
+4276 y Fi(\017)i Fg(s48)p 751 4276 V 31 w(value)e(S48)p
+1173 4276 V 30 w(RECORD)p 1467 4276 V 29 w(REF\(s48)p
+1804 4276 V 28 w(value,)g(long\))531 4376 y Fi(\017)i
+Fg(void)248 b(S48)p 1175 4376 V 30 w(RECORD)p 1469 4376
+V 29 w(SET\(s48)p 1806 4376 V 28 w(value,)39 b(long,)h(s48)p
+2529 4376 V 30 w(value\))515 4508 y Fj(The)31 b(argumen)n(t)f(to)h
+Fg(S48)p 1306 4508 V 30 w(MAKE)p 1512 4508 V 30 w(RECORD)e
+Fj(should)i(b)r(e)g(a)g(shared)f(binding)i(whose)e(v)-5
+b(alue)31 b(is)515 4608 y(a)d(record)f(t)n(yp)r(e.)40
+b(In)29 b(C)g(the)g(\014elds)g(of)f(Sc)n(heme)h(records)e(are)g(only)i
+(accessible)e(via)h(o\013sets,)515 4707 y(with)f(the)g(\014rst)g
+(\014eld)g(ha)n(ving)f(o\013set)h(zero,)f(the)h(second)f(o\013set)h
+(one,)g(and)g(so)f(forth.)36 b(If)28 b(the)515 4807 y(order)e(of)i(the)
+h(\014elds)e(is)h(c)n(hanged)f(in)h(the)h(Sc)n(heme)f(de\014nition)g
+(of)g(the)g(record)f(t)n(yp)r(e)h(the)g(C)515 4907 y(co)r(de)f(m)n(ust)
+h(b)r(e)g(up)r(dated)g(as)f(w)n(ell.)639 5006 y(F)-7
+b(or)27 b(example,)g(giv)n(en)g(the)h(follo)n(wing)f(record-t)n(yp)r(e)
+f(de\014nition)1905 5255 y(10)p eop
+%%Page: 11 11
+11 10 bop 680 523 a Fg(\(define-record-t)o(ype)37 b(thing)k(:thing)767
+623 y(\(make-thing)e(a)k(b\))767 722 y(thing?)767 822
+y(\(a)g(thing-a\))767 922 y(\(b)g(thing-b\)\))515 1081
+y Fj(the)28 b(iden)n(ti\014er)f Fg(:thing)e Fj(is)j(b)r(ound)g(to)f
+(the)h(record)e(t)n(yp)r(e)i(and)g(can)f(b)r(e)h(exp)r(orted)f(to)h(C:)
+680 1240 y Fg(\(define-exported)o(-bi)o(nd)o(ing)37 b("thing-record-ty)
+o(pe)o(")g(:thing\))515 1400 y(Thing)25 b Fj(records)h(can)h(then)i(b)r
+(e)f(made)f(in)h(C:)680 1559 y Fg(static)41 b(scheme_value)e
+(thing_record_typ)o(e_)o(bin)o(di)o(ng)e(=)43 b(SCHFALSE;)680
+1758 y(void)f(initialize_thing)o(s\(v)o(oi)o(d\))680
+1858 y Fi(f)767 1958 y Fg(S48_GC_PROTECT_GL)o(OB)o(AL\()o(th)o(ing)o
+(_r)o(ec)o(ord)o(_t)o(ype)o(_b)o(in)o(din)o(g\))o(;)767
+2057 y(thing_record_type)o(_b)o(ind)o(in)o(g)c(=)898
+2157 y(s48_get_imported)o(_bi)o(nd)o(ing)o(\(")o(th)o(ing)o(-r)o(eco)o
+(rd)o(-t)o(ype)o("\))o(;)680 2257 y Fi(g)680 2456 y Fg(scheme_value)h
+(make_thing\(schem)o(e_)o(va)o(lue)e(a,)43 b(scheme_value)38
+b(b\))680 2555 y Fi(f)767 2655 y Fg(s48_value)i(thing;)767
+2755 y(s48_DECLARE_GC_PR)o(OT)o(ECT)o(\(2)o(\);)767 2954
+y(S48_GC_PROTECT_2\()o(a,)d(b\);)767 3153 y(thing)42
+b(=)h(s48_make_record\()o(thi)o(ng)o(_r)o(eco)o(rd)o(_ty)o(pe)o(_b)o
+(ind)o(in)o(g\);)767 3253 y(S48_RECORD_SET\(th)o(in)o(g,)37
+b(0,)43 b(a\);)767 3352 y(S48_RECORD_SET\(th)o(in)o(g,)37
+b(1,)43 b(b\);)767 3552 y(S48_GC_UNPROTECT\()o(\);)767
+3751 y(return)e(thing;)680 3851 y Fi(g)515 4010 y Fj(Note)31
+b(that)g(the)g(v)-5 b(ariables)29 b Fg(a)h Fj(and)h Fg(b)f
+Fj(m)n(ust)h(b)r(e)g(protected)g(against)e(the)i(p)r(ossibilit)n(y)g
+(of)f(a)515 4110 y(garbage)25 b(collection)i(o)r(ccuring)g(during)g
+(the)h(call)f(to)g Fg(s48)p 2324 4110 27 4 v 31 w(make)p
+2531 4110 V 29 w(record\(\))p Fj(.)515 4383 y Fk(11)135
+b(Raising)46 b(exceptions)g(from)f(external)h(co)t(de)515
+4565 y Fj(The)34 b(follo)n(wing)f(macros)f(explicitly)i(raise)f
+(certain)g(errors,)h(immediately)g(returning)f(to)515
+4664 y(Sc)n(heme)k(48.)67 b(Raising)37 b(an)h(exception)f(p)r(erforms)g
+(all)h(necessary)e(clean-up)h(actions)g(to)515 4764 y(prop)r(erly)30
+b(return)g(to)h(Sc)n(heme)g(48,)g(including)h(adjusting)f(the)g(stac)n
+(k)f(of)h(protected)g(v)-5 b(ari-)515 4863 y(ables.)531
+5006 y Fi(\017)41 b Fg(s48)p 751 5006 V 31 w(raise)p
+1002 5006 V 29 w(scheme)p 1295 5006 V 29 w(exception\(int)36
+b(type,)j(int)i(nargs,)e(...\))1905 5255 y Fj(11)p eop
+%%Page: 12 12
+12 11 bop 515 523 a Fg(s48)p 652 523 27 4 v 30 w(raise)p
+902 523 V 29 w(scheme)p 1195 523 V 29 w(exception)15
+b Fj(is)k(the)h(base)e(pro)r(cedure)g(for)h(raising)e(exceptions.)34
+b Fg(type)515 623 y Fj(is)27 b(the)h(t)n(yp)r(e)f(of)h(exception,)f
+(and)g(should)h(b)r(e)f(one)g(of)h(the)g Fg(S48)p 2480
+623 V 30 w(EXCEPTION)p 2906 623 V 27 w Fj(.)14 b(.)g(.)g(constan)n(ts)
+515 722 y(de\014ned)37 b(in)f Fg(scheme48arch.h)p Fj(.)58
+b Fg(nargs)35 b Fj(is)h(the)h(n)n(um)n(b)r(er)g(of)f(additional)g(v)-5
+b(alues)36 b(to)h(b)r(e)515 822 y(included)26 b(in)h(the)f(exception;)g
+(these)g(follo)n(w)g(the)g Fg(nargs)e Fj(argumen)n(t)h(and)h(should)g
+(all)f(ha)n(v)n(e)515 922 y(t)n(yp)r(e)j Fg(s48)p 839
+922 V 30 w(value)p Fj(.)35 b Fg(s48)p 1279 922 V 30 w(raise)p
+1529 922 V 29 w(scheme)p 1822 922 V 29 w(exception)24
+b Fj(nev)n(er)i(returns.)639 1021 y(The)i(follo)n(wing)e(pro)r(cedures)
+h(are)f(a)n(v)-5 b(ailable)26 b(for)h(raising)g(particular)f(t)n(yp)r
+(es)h(of)h(excep-)515 1121 y(tions.)36 b(Lik)n(e)27 b
+Fg(s48)p 1068 1121 V 31 w(raise)p 1319 1121 V 29 w(scheme)p
+1612 1121 V 29 w(exception)d Fj(these)j(nev)n(er)g(return.)531
+1270 y Fi(\017)41 b Fg(s48)p 751 1270 V 31 w(raise)p
+1002 1270 V 29 w(argument)p 1383 1270 V 28 w(type)p 1587
+1270 V 30 w(error\(scheme)p 2145 1270 V 26 w(value\))531
+1370 y Fi(\017)g Fg(s48)p 751 1370 V 31 w(raise)p 1002
+1370 V 29 w(argument)p 1383 1370 V 28 w(number)p 1675
+1370 V 29 w(error\(int)d(nargs,)h(int)h(min,)g(int)g(max\))531
+1469 y Fi(\017)h Fg(s48)p 751 1469 V 31 w(raise)p 1002
+1469 V 29 w(index)p 1251 1469 V 29 w(range)p 1500 1469
+V 29 w(error\(long)d(value,)h(long)h(min,)g(long)f(max\))531
+1569 y Fi(\017)i Fg(s48)p 751 1569 V 31 w(raise)p 1002
+1569 V 29 w(closed)p 1295 1569 V 29 w(channel)p 1632
+1569 V 28 w(error\(\))531 1669 y Fi(\017)g Fg(s48)p 751
+1669 V 31 w(raise)p 1002 1669 V 29 w(os)p 1119 1669 V
+30 w(error\(int)d(errno\))531 1768 y Fi(\017)j Fg(s48)p
+751 1768 V 31 w(raise)p 1002 1768 V 29 w(out)p 1163 1768
+V 30 w(of)p 1281 1768 V 31 w(memory)p 1576 1768 V 28
+w(error\(\))515 1918 y Fj(An)25 b(argumen)n(t)g(t)n(yp)r(e)g(error)e
+(indicates)i(that)h(the)f(giv)n(en)g(v)-5 b(alue)25 b(is)g(of)g(the)g
+(wrong)f(t)n(yp)r(e.)37 b(An)515 2017 y(argumen)n(t)24
+b(n)n(um)n(b)r(er)h(error)e(is)i(raised)f(when)i(the)f(n)n(um)n(b)r(er)
+g(of)g(argumen)n(ts,)g Fg(nargs)p Fj(,)e(should)515 2117
+y(b)r(e,)29 b(but)h(isn't,)g(b)r(et)n(w)n(een)f Fg(min)e
+Fj(and)i Fg(max)p Fj(,)f(inclusiv)n(e.)41 b(Similarly)-7
+b(,)29 b(and)f(index)h(range)f(error)515 2217 y(is)f(raised)g(when)h
+Fg(value)d Fj(is)j(not)f(b)r(et)n(w)n(een)h(b)r(et)n(w)n(een)f
+Fg(min)g Fj(and)g Fg(max)p Fj(,)g(inclusiv)n(e.)639 2316
+y(The)g(follo)n(wing)f(macros)g(raise)g(argumen)n(t)g(t)n(yp)r(e)h
+(errors)e(if)i(their)g(argumen)n(t)f(do)r(es)h(not)515
+2416 y(ha)n(v)n(e)f(the)i(required)f(t)n(yp)r(e.)531
+2565 y Fi(\017)41 b Fg(void)f(S48)p 967 2565 V 30 w(CHECK)p
+1217 2565 V 30 w(SYMBOL\(s48)p 1687 2565 V 27 w(value\))531
+2665 y Fi(\017)h Fg(void)f(S48)p 967 2665 V 30 w(CHECK)p
+1217 2665 V 30 w(PAIR\(s48)p 1599 2665 V 28 w(value\))531
+2765 y Fi(\017)h Fg(void)f(S48)p 967 2765 V 30 w(CHECK)p
+1217 2765 V 30 w(STRING\(s48)p 1687 2765 V 27 w(value\))531
+2864 y Fi(\017)h Fg(void)f(S48)p 967 2864 V 30 w(CHECK)p
+1217 2864 V 30 w(INTEGER\(s48)p 1731 2864 V 27 w(value\))531
+2964 y Fi(\017)h Fg(void)f(S48)p 967 2964 V 30 w(CHECK)p
+1217 2964 V 30 w(CHANNEL\(s48)p 1731 2964 V 27 w(value\))531
+3064 y Fi(\017)h Fg(void)f(S48)p 967 3064 V 30 w(CHECK)p
+1217 3064 V 30 w(BYTE)p 1423 3064 V 29 w(VECTOR\(s48)p
+1892 3064 V 28 w(value\))531 3163 y Fi(\017)h Fg(void)f(S48)p
+967 3163 V 30 w(CHECK)p 1217 3163 V 30 w(RECORD\(s48)p
+1687 3163 V 27 w(value\))531 3263 y Fi(\017)h Fg(void)f(S48)p
+967 3263 V 30 w(CHECK)p 1217 3263 V 30 w(SHARED)p 1511
+3263 V 29 w(BINDING\(s48)p 2024 3263 V 26 w(value\))515
+3537 y Fk(12)135 b(Unsafe)46 b(functions)e(and)h(macros)515
+3719 y Fj(All)24 b(of)h(the)f(C)h(pro)r(cedures)e(and)h(macros)e
+(describ)r(ed)i(ab)r(o)n(v)n(e)f(c)n(hec)n(k)h(that)g(their)g(argumen)n
+(ts)515 3819 y(ha)n(v)n(e)h(the)i(appropriate)e(t)n(yp)r(es)i(and)f
+(that)h(indexes)f(are)g(in)h(range.)35 b(The)27 b(follo)n(wing)e(pro)r
+(ce-)515 3918 y(dures)20 b(and)i(macros)d(are)i(iden)n(tical)g(to)g
+(those)g(describ)r(ed)g(ab)r(o)n(v)n(e,)g(except)g(that)h(they)f(do)g
+(not)515 4018 y(p)r(erform)31 b(t)n(yp)r(e)h(and)f(range)g(c)n(hec)n
+(ks.)48 b(They)31 b(are)g(pro)n(vided)g(for)g(the)h(purp)r(ose)f(of)g
+(writing)515 4118 y(more)c(e\016cien)n(t)g(co)r(de;)h(their)f(general)f
+(use)i(is)f(not)h(recommended.)531 4267 y Fi(\017)41
+b Fg(char)248 b(S48)p 1175 4267 V 30 w(UNSAFE)p 1469
+4267 V 29 w(EXTRACT)p 1806 4267 V 28 w(CHAR\(s48)p 2186
+4267 V 28 w(value\))531 4367 y Fi(\017)41 b Fg(char)f(*)166
+b(S48)p 1177 4367 V 30 w(UNSAFE)p 1471 4367 V 29 w(EXTRACT)p
+1808 4367 V 28 w(STRING\(s48)p 2276 4367 V 28 w(value\))531
+4466 y Fi(\017)41 b Fg(long)248 b(S48)p 1175 4466 V 30
+w(UNSAFE)p 1469 4466 V 29 w(EXTRACT)p 1806 4466 V 28
+w(INTEGER\(s48)p 2318 4466 V 27 w(value\))531 4566 y
+Fi(\017)41 b Fg(long)248 b(S48)p 1175 4566 V 30 w(UNSAFE)p
+1469 4566 V 29 w(EXTRACT)p 1806 4566 V 28 w(DOUBLE\(s48)p
+2274 4566 V 28 w(value\))531 4715 y Fi(\017)41 b Fg(long)248
+b(S48)p 1175 4715 V 30 w(UNSAFE)p 1469 4715 V 29 w(EXTRACT)p
+1806 4715 V 28 w(FIXNUM\(s48)p 2274 4715 V 28 w(value\))531
+4815 y Fi(\017)41 b Fg(s48)p 751 4815 V 31 w(value)e(S48)p
+1173 4815 V 30 w(UNSAFE)p 1467 4815 V 29 w(ENTER)p 1716
+4815 V 29 w(FIXNUM\(long\))531 4964 y Fi(\017)i Fg(s48)p
+751 4964 V 31 w(value)e(S48)p 1173 4964 V 30 w(UNSAFE)p
+1467 4964 V 29 w(CAR\(s48)p 1804 4964 V 28 w(value\))1905
+5255 y Fj(12)p eop
+%%Page: 13 13
+13 12 bop 531 523 a Fi(\017)41 b Fg(s48)p 751 523 27
+4 v 31 w(value)e(S48)p 1173 523 V 30 w(UNSAFE)p 1467
+523 V 29 w(CDR\(s48)p 1804 523 V 28 w(value\))531 623
+y Fi(\017)i Fg(void)248 b(S48)p 1175 623 V 30 w(UNSAFE)p
+1469 623 V 29 w(SET)p 1630 623 V 30 w(CAR\(s48)p 1968
+623 V 28 w(value,)39 b(s48)p 2431 623 V 31 w(value\))531
+722 y Fi(\017)i Fg(void)248 b(S48)p 1175 722 V 30 w(UNSAFE)p
+1469 722 V 29 w(SET)p 1630 722 V 30 w(CDR\(s48)p 1968
+722 V 28 w(value,)39 b(s48)p 2431 722 V 31 w(value\))531
+872 y Fi(\017)i Fg(long)248 b(S48)p 1175 872 V 30 w(UNSAFE)p
+1469 872 V 29 w(VECTOR)p 1762 872 V 29 w(LENGTH\(s48)p
+2231 872 V 27 w(value\))531 971 y Fi(\017)41 b Fg(s48)p
+751 971 V 31 w(value)e(S48)p 1173 971 V 30 w(UNSAFE)p
+1467 971 V 29 w(VECTOR)p 1760 971 V 29 w(REF\(s48)p 2097
+971 V 28 w(value,)g(long\))531 1071 y Fi(\017)i Fg(void)248
+b(S48)p 1175 1071 V 30 w(UNSAFE)p 1469 1071 V 29 w(VECTOR)p
+1762 1071 V 29 w(SET\(s48)p 2099 1071 V 28 w(value,)39
+b(long,)h(s48)p 2822 1071 V 30 w(value\))531 1220 y Fi(\017)h
+Fg(long)248 b(S48)p 1175 1220 V 30 w(UNSAFE)p 1469 1220
+V 29 w(STRING)p 1762 1220 V 29 w(LENGTH\(s48)p 2231 1220
+V 27 w(value\))531 1320 y Fi(\017)41 b Fg(char)248 b(S48)p
+1175 1320 V 30 w(UNSAFE)p 1469 1320 V 29 w(STRING)p 1762
+1320 V 29 w(REF\(s48)p 2099 1320 V 28 w(value,)39 b(long\))531
+1420 y Fi(\017)i Fg(void)248 b(S48)p 1175 1420 V 30 w(UNSAFE)p
+1469 1420 V 29 w(STRING)p 1762 1420 V 29 w(SET\(s48)p
+2099 1420 V 28 w(value,)39 b(long,)h(char\))531 1569
+y Fi(\017)h Fg(s48)p 751 1569 V 31 w(value)e(S48)p 1173
+1569 V 30 w(UNSAFE)p 1467 1569 V 29 w(SYMBOL)p 1760 1569
+V 29 w(TO)p 1877 1569 V 30 w(STRING\(s48)p 2347 1569
+V 28 w(value\))531 1719 y Fi(\017)i Fg(long)248 b(S48)p
+1175 1719 V 30 w(UNSAFE)p 1469 1719 V 29 w(BYTE)p 1674
+1719 V 30 w(VECTOR)p 1968 1719 V 28 w(LENGTH\(s48)p 2436
+1719 V 28 w(value\))531 1818 y Fi(\017)41 b Fg(char)248
+b(S48)p 1175 1818 V 30 w(UNSAFE)p 1469 1818 V 29 w(BYTE)p
+1674 1818 V 30 w(VECTOR)p 1968 1818 V 28 w(REF\(s48)p
+2304 1818 V 29 w(value,)39 b(long\))531 1918 y Fi(\017)i
+Fg(void)248 b(S48)p 1175 1918 V 30 w(UNSAFE)p 1469 1918
+V 29 w(BYTE)p 1674 1918 V 30 w(VECTOR)p 1968 1918 V 28
+w(SET\(s48)p 2304 1918 V 29 w(value,)39 b(long,)g(int\))531
+2067 y Fi(\017)i Fg(s48)p 751 2067 V 31 w(value)e(S48)p
+1173 2067 V 30 w(UNSAFE)p 1467 2067 V 29 w(SHARED)p 1760
+2067 V 29 w(BINDING)p 2097 2067 V 28 w(REF\(s48)p 2433
+2067 V 29 w(value)g(s)p 2765 2067 V 31 w(b\))531 2167
+y Fi(\017)i Fg(int)290 b(S48)p 1173 2167 V 30 w(UNSAFE)p
+1467 2167 V 29 w(SHARED)p 1760 2167 V 29 w(BINDING)p
+2097 2167 V 28 w(P\(x\))531 2267 y Fi(\017)41 b Fg(int)290
+b(S48)p 1173 2267 V 30 w(UNSAFE)p 1467 2267 V 29 w(SHARED)p
+1760 2267 V 29 w(BINDING)p 2097 2267 V 28 w(IS)p 2213
+2267 V 31 w(IMPORT)p 2508 2267 V 29 w(P\(s48)p 2757 2267
+V 29 w(value)39 b(s)p 3089 2267 V 31 w(b\))531 2366 y
+Fi(\017)i Fg(s48)p 751 2366 V 31 w(value)e(S48)p 1173
+2366 V 30 w(UNSAFE)p 1467 2366 V 29 w(SHARED)p 1760 2366
+V 29 w(BINDING)p 2097 2366 V 28 w(NAME\(s48)p 2477 2366
+V 28 w(value)h(s)p 2809 2366 V 31 w(b\))531 2466 y Fi(\017)h
+Fg(void)248 b(S48)p 1175 2466 V 30 w(UNSAFE)p 1469 2466
+V 29 w(SHARED)p 1762 2466 V 29 w(BINDING)p 2099 2466
+V 28 w(SET\(s48)p 2435 2466 V 29 w(value)39 b(s)p 2767
+2466 V 31 w(b,)i(s48)p 3059 2466 V 30 w(value)e(value\))531
+2615 y Fi(\017)i Fg(s48)p 751 2615 V 31 w(value)e(S48)p
+1173 2615 V 30 w(UNSAFE)p 1467 2615 V 29 w(RECORD)p 1760
+2615 V 29 w(TYPE\(s48)p 2141 2615 V 28 w(value\))531
+2715 y Fi(\017)i Fg(s48)p 751 2715 V 31 w(value)e(S48)p
+1173 2715 V 30 w(UNSAFE)p 1467 2715 V 29 w(RECORD)p 1760
+2715 V 29 w(REF\(s48)p 2097 2715 V 28 w(value,)g(long\))531
+2814 y Fi(\017)i Fg(void)248 b(S48)p 1175 2814 V 30 w(UNSAFE)p
+1469 2814 V 29 w(RECORD)p 1762 2814 V 29 w(SET\(s48)p
+2099 2814 V 28 w(value,)39 b(long,)h(s48)p 2822 2814
+V 30 w(value\))531 2964 y Fi(\017)h Fg(type)248 b(S48)p
+1175 2964 V 30 w(UNSAFE)p 1469 2964 V 29 w(EXTRACT)p
+1806 2964 V 28 w(VALUE\(s48)p 2230 2964 V 28 w(value,)39
+b(type\))531 3064 y Fi(\017)i Fg(type)f(*)166 b(S48)p
+1177 3064 V 30 w(UNSAFE)p 1471 3064 V 29 w(EXTRACT)p
+1808 3064 V 28 w(VALUE)p 2056 3064 V 30 w(POINTER\(s48)p
+2570 3064 V 27 w(value,)39 b(type\))531 3163 y Fi(\017)i
+Fg(void)248 b(S48)p 1175 3163 V 30 w(UNSAFE)p 1469 3163
+V 29 w(SET)p 1630 3163 V 30 w(VALUE\(s48)p 2056 3163
+V 28 w(value,)39 b(type,)g(value\))1905 5255 y Fj(13)p
+eop
+%%Trailer
+end
+userdict /end-hook known{end-hook}if
+%%EOF
diff --git a/doc/hacking.txt b/doc/hacking.txt
new file mode 100644
index 0000000..081d7e5
--- /dev/null
+++ b/doc/hacking.txt
@@ -0,0 +1,290 @@
+
+,bench
+,load-package linker
+,new-package =link= linker debuginfo defpackage
+,load scripts.scm
+(link-initial-system)
+
+
+To change between initial image starting in mini-command (MINI) and
+command (MAXI):
+
+  1. Definition of initial system's command module in comp-packages.scm:
+     MINI: (make-mini-command scheme)
+     MAXI: (make-command scheme)
+  2. Location of (define-module (make-command ...)...):
+     MINI: more-packages.scm
+     MAXI: comp-packages.scm
+  3. Location of (define-interface command-interface ...):
+     MINI: more-interfaces.scm
+     MAXI: interfaces.scm
+
+
+
+
+> ,new-package z architecture primitives packages table enumerated debug-data
+z> (let ((i 0))
+     (table-walk (lambda (x y) (set! i (+ i 1)))
+	         location-name-table)
+      i)
+1385
+z> (vector-length (find-all-xs (name->enumerand 'location stob)))
+1259
+(vector-length (find-all-xs (name->enumerand 'record stob)))
+2150
+
+(find-all-xs (name->enumerand 'record stob))
+z> (do ((i 0 (+ i 1))
+        (j 0 (if (package? (vector-ref rs i)) (+ j 1) j))) ((= i (vector-length rs)) j))
+72
+z> 
+
+
+
+
+> ,new-package z architecture primitives compiler table
+z> (vector-ref stob 10)
+'template
+z> stob
+'#(pair symbol vector closure location port ratio record continuation extended-number template weak-pointer external unused-d-header1 unused-d-header2 string code-vector double bignum)
+z> (vector-ref stob 7)
+'record
+z> (define rs (find-all-xs 7))
+z> (vector-length rs)
+2178
+z> (define ls (find-all-xs 4))
+z> (vector-length ls)
+1266
+z> 
+
+
+
+
+To get a fresh config package:
+
+,in config (define-structures ((config1 (export)))
+	     (open defpackage built-in-structures more-structures))
+,config-package-is config1
+
+
+To load a linker with a fresh new compiler:
+    x48 -i new-scheme48.image -h 10000000 <l.s48
+
+Then  ,load scripts.scm  or whatever.
+
+
+
+
+These are all files not belonging to any package description:
+
+    boot-packages.scm
+    comp-packages.scm
+    flatload.scm
+    more-packages.scm
+    more-interfaces.scm
+    rts-packages.scm
+    scripts.scm
+    interfaces.scm
+
+    infix/
+    debug/
+    alt/
+
+    link/p-features.scm
+    link/p-record.scm
+    link/t-features.scm
+    link/t-record.scm
+
+    misc/icon.scm
+    misc/mail.scm         -- related to more-thread.scm
+    misc/more-thread.scm  -- needs work
+    misc/sicp.scm	  -- add to more-packages
+
+
+,load-package rk-extensions
+,new-package rk-user rk-extensions
+,user-package-is rk-user
+
+
+
+# If initial images starts in mini-command instead of command, the
+# rule for $(IMAGE) becomes something like this:
+#	(echo ,load more-interfaces.scm $(S48ROOT)/more-packages.scm; \
+#	 echo "(ensure-loaded command)"; \
+#	 echo ",go ((structure-ref command 'command-processor) batch)"; \
+
+
+,in config (define-structures ((reification (export reify-structures)))
+  (open scheme-level-2 table
+	signals			;error
+	packages
+	features		;location-id location?
+	scan)			;find-free-names-in-syntax-rules
+  (files (link reify)))
+
+,load-package reification
+
+debug-config> ,in reification reify-structures
+'#{Procedure 8447 reify-structures}
+debug-config> (define reify-structures ##)
+debug-config> make-simple-package
+
+Error: undefined variable
+       make-simple-package
+       (package debug-config)
+1 debug-config> 
+debug-config> (define-structures ((p (export start))) (open initial-system scheme-level-2 packages))
+debug-config> (define go (in p `(start ,(reify-structures (desirable-packages) (lambda (loc) `',loc)))))
+
+
+
+### Small images for exercising the linker and/or runtime system
+
+debug/tiny.image: debug/tiny.scm $(LINKER_IMAGE)
+	($(START_LINKER_RUNNABLE) \
+	 echo "(load \"debug/tiny-packages.scm\")"; \
+	 echo "(link-simple-system '(debug tiny) 'start tiny-system)") \
+	| $(LINKER_RUNNABLE) -i $(LINKER_IMAGE)
+
+debug/little.image: $(LINKER_IMAGE) $(CONFIG_FILES) $(little-files)
+	($(START_LINKER_RUNNABLE) \
+	 echo "(load \"scripts.scm\")";  \
+	 echo "(link-little-system)")	 \
+	| $(LINKER_RUNNABLE) -i $(LINKER_IMAGE) $(BIG_HEAP)
+
+debug/medium.image: $(LINKER_IMAGE) $(CONFIG_FILES) $(medium-files)
+	($(START_LINKER_RUNNABLE) \
+	 echo "(load \"scripts.scm\")";  \
+	 echo "(link-medium-system)") \
+	| $(LINKER_RUNNABLE) -i $(LINKER_IMAGE) $(BIG_HEAP)
+
+
+	 echo "(define l-f (package-all-filenames little-system))";  \
+	 echo "(define m-f (package-all-filenames medium-system))";  \
+
+		 'little-files l-f 'medium-files m-f	      \
+
+
+[The following is from June 1992, and probably not quite compatible
+with the current compiler internals.]
+
+To eliminate use of the stack GC to implement tail recursion, change
+comp.scm as follows:
+
+(define (compile-unknown-call exp cenv depth cont)
+  (note-source-code
+   exp
+   (maybe-push-continuation (sequentially 
+			     (push-all (cdr exp) cenv 0)
+			     (compile (car exp)
+				      cenv
+				      (length (cdr exp))
+				      (fall-through-cont))
+			     (instruction (if (return-cont? cont)
+					  op/move-args-and-call
+					  op/call)
+					  (length (cdr exp))))
+			    depth
+			    cont)))
+
+
+--------------------
+
+Here's another cool thing.  6/28/93
+
+(define-interface evaluation-interface
+  (export eval load eval-from-file))
+
+(define-structure run evaluation-interface
+  (open scheme-level-2 syntactic packages scan
+	environments
+	signals
+	locations
+	features   ;force-output
+	table
+	fluids)
+  (files (debug run)))
+
+,load-package run
+,in run
+,in package-commands (environment-for-syntax-promise)
+(define cool (make-simple-package (list scheme) eval ## 'cool))
+,in command set-environment-for-commands!
+(## cool)
+
+cool> ,inspect (lambda (x) x)
+'#{Procedure 6394}
+
+ [0: exp] '(lambda (x) x)
+ [1: env] '#{Package 286 cool}
+inspect: 
+inspect: q
+cool> 
+
+
+
+(define (z s)
+  (define (show-type name static)
+    (write name)
+    (display "	: ")
+    (write (static-type static))
+    (newline))
+  (if (package? s)
+      (for-each-definition (lambda (name static loc)
+			     (show-type name static))
+			   s)
+      (interface-walk (lambda (name type)
+			(show-type name
+				   (car (structure-lookup
+					 s name #t))))
+		      (structure-interface s))))
+
+; ,open expander syntactic packages reconstruction
+
+(define (e x)
+  (let ((p (interaction-environment)))
+    (let ((node (expand-form x p)))
+      (write (node-type node (package->environment p)))
+      (newline)
+      (eval node p))))
+
+
+
+> (define hunk3 (lap hunk3
+		     0 (check-nargs= 3)
+		     2 (pop)
+		     3 (make-stored-object 3 0)
+		     6 (return)))
+> (hunk3 1  2 3)
+'(1 . 2)
+> (define cxr (lap cxr
+		   0 (check-nargs= 2)
+		   2 (pop)
+		   3 (stored-object-indexed-ref 0)
+		   5 (return)))
+> (cxr (hunk3 1  2 3) 2)
+3
+> 
+
+
+(define-syntax %cons
+  (lambda (e r c)
+    (let ((n (cadr e))
+	  (kind (caddr e)))
+      `(,(r 'lap) (%cons ,n ,kind)
+		  (check-nargs= ,n)
+		  (pop)
+		  (make-stored-object ,n ,kind)
+		  (return)))))
+
+
+(define (& x)
+  (or (node-ref x 'uid)
+      (begin (set! *n* (+ *n* 1))
+	     (node-set! x 'uid *n*)
+	     *n*))
+  x)
+
+(define (uid n) (node-ref (& n) 'uid))
+
+(define *n* 0)
diff --git a/doc/html/external.html b/doc/html/external.html
new file mode 100644
index 0000000..61ca405
--- /dev/null
+++ b/doc/html/external.html
@@ -0,0 +1,690 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2 Final//EN">
+<HTML>
+<!-- HTML file produced from file: external.tex --
+ -- using Hyperlatex v 2.3.1 (c) Otfried Cheong--
+ -- on Emacs 19.34.1, Tue Feb 23 18:21:44 1999 -->
+<HEAD>
+<TITLE>Mixing Scheme 48 and C</TITLE>
+
+</HEAD><BODY>
+
+
+    <H1 ALIGN=CENTER>Using C code with Scheme 48</H1>
+    <H2 ALIGN=CENTER>Mike Sperber<BR><TT><FONT SIZE=-1>sperber@informatik.uni-tuebingen.de</FONT></TT><BR>Richard Kelsey<BR><TT><FONT SIZE=-1>kelsey@research.nj.nec.com</FONT></TT>
+  </H2>
+    <H3 ALIGN=CENTER>February 23, 1999</H3>
+    <H3 ALIGN=CENTER>Abstract</H3>
+  <BLOCKQUOTE>
+This document describes an interface for calling C functions
+ from Scheme, calling Scheme functions from C, and allocating
+ storage in the Scheme heap.
+These facilities are designed to link
+ existing C libraries into Scheme&nbsp;48 in order to use them from Scheme.
+To this end, Scheme&nbsp;48 manages stub functions in C that
+ negotiate between the calling conventions of Scheme and C and the
+ memory allocation policies of both worlds.
+No stub generator is available yet, but writing them is a straightforward task.
+</BLOCKQUOTE>
+<H1><A NAME="1">Available Facilities</A></H1>
+
+<P>The following facilities are available for interfacing between
+ Scheme&nbsp;48 and C:
+<UL><LI>Scheme code can call C functions.
+<LI>The external interface provides full introspection for all
+  Scheme objects.  External code may inspect, modify, and allocate
+  Scheme objects arbitrarily.
+<LI>External code may raise exceptions back to Scheme&nbsp;48 to
+  signal errors.
+<LI>External code may call back into Scheme.  Scheme&nbsp;48
+  correctly unrolls the process stack on non-local exits.
+<LI>External modules may register bindings of names to values with a 
+  central registry accessible from
+  Scheme.  Conversely, Scheme code can register shared
+  bindings for access by C code.
+</UL>
+This document has three parts: the first describes how bindings are
+ moved from Scheme to C and vice versa, the second tells how to call
+ C functions from Scheme, and the third covers the C interface
+ to Scheme objects, including calling Scheme procedures, using the
+ Scheme heap, and so forth.
+<H2><A NAME="2">Scheme structures</A></H2>
+<P>The structure <CODE>external-calls</CODE> has 
+ most of the Scheme functions described here.
+The others are in 
+ <CODE>dynamic-externals</CODE>, which has the functions for dynamic loading and
+ name lookup from
+
+the section on <A HREF="#dynamic-externals">Dynamic Loading</A>,
+ and <CODE>shared-bindings</CODE>, which has the additional shared-binding functions
+ described in
+
+the section on the <A HREF="#more-shared-bindings">complete shared-binding interface</A>.
+<H2><A NAME="3">C naming conventions</A></H2>
+<P>The names of all of Scheme&nbsp;48's visible C bindings begin 
+ with `<CODE>s48_</CODE>' (for procedures and variables) or 
+ `<CODE>S48_</CODE>' (for macros).
+Whenever a C name is derived from a Scheme identifier, we
+ replace `<CODE>-</CODE>' with `<CODE>_</CODE>' and convert letters to lowercase
+ for procedures and uppercase for macros.
+A final `<CODE>?</CODE>'  converted to `<CODE>_p</CODE>' (`<CODE>_P</CODE>' in C macro names).
+A final `<CODE>!</CODE>' is dropped.
+Thus the C macro for Scheme's <CODE>pair?</CODE> is <CODE>S48_PAIR_P</CODE> and
+ the one for <CODE>set-car!</CODE> is <CODE>S48_SET_CAR</CODE>.
+Procedures and macros that do not check the types of their arguments
+ have `<CODE>unsafe</CODE>' in their names.
+<P>All of the C functions and macros described have prototypes or definitions
+ in the file <CODE>c/scheme48.h</CODE>.
+The C type for Scheme values is defined there to be <CODE>s48_value</CODE>.
+<H1><A NAME="4">Shared bindings</A></H1>
+
+<P>Shared bindings are the means by which named values are shared between Scheme
+ code and C code.
+There are two separate tables of shared bindings, one for values defined in
+ Scheme and accessed from C and the other for values going the other way.
+Shared bindings actually bind names to cells, to allow a name to be looked
+ up before it has been assigned.
+This is necessary because C initialization code may be run before or after
+ the corresponding Scheme code, depending on whether the Scheme code is in
+ the resumed image or is run in the current session.
+<H2><A NAME="5">Exporting Scheme values to C</A></H2>
+<UL><LI><CODE>(define-exported-binding<I>&nbsp;name&nbsp;value</I>)&nbsp;-&gt;&nbsp;<I>shared-binding</I></CODE>
+</UL>
+<UL><LI><CODE>s48_value s48_get_imported_binding(char *name)</CODE>
+<LI><CODE>s48_value S48_SHARED_BINDING_REF(s48_value shared_binding)</CODE>
+</UL>
+<P><CODE>Define-exported-binding</CODE> makes <CODE><I>value</I></CODE> available to C code
+ under as <CODE><I>name</I></CODE> which must be a <CODE><I>string</I></CODE>, creating a new shared
+ binding if necessary.
+The C function <CODE>s48_get_imported_binding</CODE> returns the shared binding
+ defined for <CODE>name</CODE>, again creating it if necessary.
+The C macro <CODE>S48_SHARED_BINDING_REF</CODE> dereferences a shared binding,
+ returning its current value.
+<H2><A NAME="6">Exporting C values to Scheme</A></H2>
+<UL><LI><CODE>void s48_define_exported_binding(char *name, s48_value value)</CODE>
+</UL>
+<UL><LI><CODE>(lookup-imported-binding<I>&nbsp;string</I>)&nbsp;-&gt;&nbsp;<I>shared-binding</I></CODE>
+<LI><CODE>(shared-binding-ref<I>&nbsp;shared-binding</I>)&nbsp;-&gt;&nbsp;<I>value</I></CODE>
+</UL>
+<P>These are used to define shared bindings from C and to access them
+ from Scheme.
+Again, if a name is looked up before it has been defined, a new binding is
+ created for it.
+<P>The common case of exporting a C function to Scheme can be done using
+ the macro <CODE>S48_EXPORT_FUNCTION(<EM>name</EM>)</CODE>.
+This expands into
+<P><CODE>s48_define_exported_binding("<CODE><I>name</I></CODE>", s48_enter_pointer(<CODE><I>name</I></CODE>))</CODE>
+<P>which boxes the function into a Scheme byte vector and then
+ exports it.
+Note that <CODE>s48_enter_pointer</CODE> allocates space in the Scheme heap
+ and might trigger a 
+ <A HREF="#gc">garbage collection</A>.
+<UL><LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
+<tr> <td><CODE>(import-definition <CODE><I>name</I></CODE>)</CODE></td> <td align=right>syntax</td></tr></table>
+<LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
+<tr> <td><CODE>(import-definition <CODE><I>name&nbsp;c-name</I></CODE>)</CODE></td> <td align=right>syntax</td></tr></table>
+</UL>
+These macros simplify importing definitions from C to Scheme.
+They expand into
+<P><CODE>(define <CODE><I>name</I></CODE> (lookup-imported-binding <CODE><I>c-name</I></CODE>))</CODE>
+<P>where <CODE><I>c-name</I></CODE> is as supplied for the second form.
+For the first form <CODE><I>c-name</I></CODE> is derived from <CODE><I>name</I></CODE> by
+ replacing `<CODE>-</CODE>' with `<CODE>_</CODE>' and converting letters to lowercase.
+For example, <CODE>(import-definition my-foo)</CODE> expands into
+<P><CODE>(define my-foo (lookup-imported-binding "my_foo"))</CODE>
+<H2><A NAME="more-shared-bindings">Complete shared binding interface</A></H2>
+
+<P>There are a number of other Scheme functions related to shared bindings;
+ these are in the structure <CODE>shared-bindings</CODE>.
+<UL><LI><CODE>(shared-binding?<I>&nbsp;x</I>)&nbsp;-&gt;&nbsp;<I>boolean</I></CODE>
+<LI><CODE>(shared-binding-name<I>&nbsp;shared-binding</I>)&nbsp;-&gt;&nbsp;<I>string</I></CODE>
+<LI><CODE>(shared-binding-is-import?<I>&nbsp;shared-binding</I>)&nbsp;-&gt;&nbsp;<I>boolean</I></CODE>
+<LI><CODE>(shared-binding-set!<I>&nbsp;shared-binding&nbsp;value</I>)</CODE>
+<LI><CODE>(define-imported-binding<I>&nbsp;string&nbsp;value</I>)</CODE>
+<LI><CODE>(lookup-exported-binding<I>&nbsp;string</I>)</CODE>
+<LI><CODE>(undefine-imported-binding<I>&nbsp;string</I>)</CODE>
+<LI><CODE>(undefine-exported-binding<I>&nbsp;string</I>)</CODE>
+</UL>
+<P><CODE>Shared-binding?</CODE> is the predicate for shared-bindings.
+<CODE>Shared-binding-name</CODE> returns the name of a binding.
+<CODE>Shared-binding-is-import?</CODE> is true if the binding was defined from C.
+<CODE>Shared-binding-set!</CODE> changes the value of a binding.
+<CODE>Define-imported-binding</CODE> and <CODE>lookup-exported-binding</CODE> are
+ Scheme versions of <CODE>s48_define_exported_binding</CODE>
+ and <CODE>s48_lookup_imported_binding</CODE>.
+The two <CODE>undefine-</CODE> procedures remove bindings from the two tables.
+They do nothing if the name is not found in the table.
+<P>The following C macros correspond to the Scheme functions above.
+<UL><LI><CODE>int       S48_SHARED_BINDING_P(x)</CODE>
+<LI><CODE>int       S48_SHARED_BINDING_IS_IMPORT_P(s48_value s_b)</CODE>
+<LI><CODE>s48_value S48_SHARED_BINDING_NAME(s48_value s_b)</CODE>
+<LI><CODE>void      S48_SHARED_BINDING_SET(s48_value s_b, s48_value value)</CODE>
+</UL>
+<H1><A NAME="8">Calling C Functions from Scheme</A></H1>
+
+<P>There are three different ways to call C functions from Scheme, depending on
+ how the C function was obtained.
+<UL><LI><CODE>(call-imported-binding<I>&nbsp;binding&nbsp;arg<I><sub>0</sub></I>&nbsp;...</I>)&nbsp;-&gt;&nbsp;<I>value</I></CODE>
+<LI><CODE>(call-external<I>&nbsp;external&nbsp;arg<I><sub>0</sub></I>&nbsp;...</I>)&nbsp;-&gt;&nbsp;<I>value</I></CODE>
+<LI><CODE>(call-external-value<I>&nbsp;value&nbsp;name&nbsp;arg<I><sub>0</sub></I>&nbsp;...</I>)&nbsp;-&gt;&nbsp;<I>value</I></CODE>
+</UL>
+Each of these applies its first argument, a C function, to the rest of
+ the arguments.
+For <CODE>call-imported-binding</CODE> the function argument must be an
+ imported binding.
+For <CODE>call-external</CODE> the function argument must be an external
+ bound in the current process
+ (see
+
+the section on <A HREF="#dynamic-externals">Dynamic Loading</A>).
+For <CODE>call-external-value</CODE> <CODE><I>value</I></CODE> must be a byte vector
+ whose contents is a pointer to a C function and <CODE><I>name</I></CODE> should be
+ a string naming the function.
+The <CODE><I>name</I></CODE> argument is used only for printing error messages.
+<P>For all of these, the C function is passed the <CODE><I>arg<I><sub>i</sub></I></I></CODE> values
+ and the value returned is that returned by C procedure.
+Up to twelve arguments may be passed.
+There is no method supplied for returning multiple values to
+ Scheme from C (or vice versa) (mainly because C does not have multiple return
+ values).
+<P>Keyboard interrupts that occur during a call to a C function are ignored
+ until the function returns to Scheme (this is clearly a
+ problem; we are working on a solution).
+<UL><LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
+<tr> <td><CODE>(import-lambda-definition <CODE><I>name</I></CODE> (<CODE><I>formal</I></CODE> ...))</CODE></td> <td align=right>syntax</td></tr></table>
+<LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
+<tr> <td><CODE>(import-lambda-definition <CODE><I>name</I></CODE> (<CODE><I>formal</I></CODE> ...) <CODE><I>c-name</I></CODE>)</CODE></td> <td align=right>syntax</td></tr></table>
+</UL>
+These macros simplify importing functions from C.
+They define <CODE><I>name</I></CODE> to be a function with the given formals that
+ applies those formals to the corresponding C binding.
+<CODE><I>C-name</I></CODE>, if supplied, should be a string.
+These expand into
+<BLOCKQUOTE><PRE>
+(define temp (lookup-imported-binding <CODE><I>c-name</I></CODE>))
+(define <CODE><I>name</I></CODE>
+  (lambda (<CODE><I>formal</I></CODE> ...)
+    (external-apply temp <CODE><I>formal</I></CODE> ...)))
+</PRE></BLOCKQUOTE>
+<P>
+If <CODE><I>c-name</I></CODE> is not supplied, it is derived from <CODE><I>name</I></CODE> by converting
+ all letters to lowercase and replacing `<CODE>-</CODE>' with `<CODE>_</CODE>'.
+<H1><A NAME="9">Adding external modules to the <CODE>Makefile</CODE></A></H1>
+
+<P>Getting access to C bindings from Scheme requires that the C code be
+ compiled an linked in with the Scheme&nbsp;48 virtual machine and that the
+ relevent shared-bindings be created.
+The Scheme&nbsp;48 makefile has rules for compiling and linking external code
+ and for specifying initialization functions that should be called on
+ startup.
+There are three Makefile variables that control which external modules are
+ included in the executable for the virutal machine (<CODE>scheme48vm</CODE>).
+<CODE>EXTERNAL_OBJECTS</CODE> lists the object files to be included in
+ <CODE>scheme48vm</CODE>,
+<CODE>EXTERNAL_FLAGS</CODE> is a list of <CODE>ld</CODE> flags to be used when
+ creating <CODE>scheme48vm</CODE>, and
+ <CODE>EXTERNAL_INITIALIZERS</CODE> is a list of C procedures to be called
+ on startup.
+The procedures listed in <CODE>EXTERNAL_INITIALIZERS</CODE> should take no
+ arguments and have a return type of <CODE>void</CODE>.
+After changing the definitions of any of these variables you should
+ do <CODE>make scheme48vm</CODE> to rebuild the virtual machine.
+<H1><A NAME="dynamic-externals">Dynamic Loading</A></H1>
+
+<P>External code can be loaded into a running Scheme&nbsp;48 process
+ and C object-file bindings can be dereferenced at runtime and
+ their values called
+ (although not all versions of Unix support all of this).
+The required Scheme functions are in the structure <CODE>dynamic-externals</CODE>.
+<UL><LI><CODE>(dynamic-load<I>&nbsp;string</I>)</CODE>
+</UL>
+<CODE>Dynamic-load</CODE> loads the named file into the current
+ process, raising an exception if the file cannot be found or if dynamic
+ loading is not supported by the operating system.
+The file must have been compiled and linked appropriately.
+For Linux, the following commands compile <CODE>foo.c</CODE> into a
+ file <CODE>foo.so</CODE> that can be loaded dynamically.
+<BLOCKQUOTE><PRE>
+% gcc -c -o foo.o foo.c
+% ld -shared -o foo.so foo.o
+</PRE></BLOCKQUOTE>
+<UL><LI><CODE>(get-external<I>&nbsp;string</I>)&nbsp;-&gt;&nbsp;<I>external</I></CODE>
+<LI><CODE>(external?<I>&nbsp;x</I>)&nbsp;-&gt;&nbsp;<I>boolean</I></CODE>
+<LI><CODE>(external-name<I>&nbsp;external</I>)&nbsp;-&gt;&nbsp;<I>string</I></CODE>
+<LI><CODE>(external-value<I>&nbsp;external</I>)&nbsp;-&gt;&nbsp;<I>byte-vector</I></CODE>
+</UL>
+These functions give access to values bound in the current process, and
+ are used for retrieving values from dynamically-loaded files.
+<CODE>Get-external</CODE> returns an <I>external</I> object that contains the
+ value of <CODE><I>name</I></CODE>, raising an exception if there is no such
+ value in the current process.
+<CODE>External?</CODE> is the predicate for externals, and
+<CODE>external-name</CODE> and <CODE>external-value</CODE> return the name and
+ value of an external.
+The value is returned as byte vector of length four (on 32-bit
+ architectures).
+The value is that which was extant when <CODE>get-external</CODE> was
+ called.
+The following two functions can be used to update the values of
+ externals.
+<UL><LI><CODE>(lookup-external<I>&nbsp;external</I>)&nbsp;-&gt;&nbsp;<I>boolean</I></CODE>
+<LI><CODE>(lookup-all-externals<I></I>)&nbsp;-&gt;&nbsp;<I>boolean</I></CODE>
+</UL>
+<CODE>Lookup-external</CODE> updates the value of <CODE><I>external</I></CODE> by looking its
+ name in the current process, returning <CODE>#t</CODE> if it is bound and <CODE>#f</CODE>
+ if it is not.
+<CODE>Lookup-all-externals</CODE> calls <CODE>lookup-external</CODE> on all extant
+ externals, returning <CODE>#f</CODE> any are unbound.
+<UL><LI><CODE>(call-external<I>&nbsp;external&nbsp;arg<I><sub>0</sub></I>&nbsp;...</I>)&nbsp;-&gt;&nbsp;<I>value</I></CODE>
+</UL>
+An external whose value is a C procedure can be called using
+ <CODE>call-external</CODE>.
+See
+
+the section on <A HREF="#8">calling C functions from Scheme</A>
+for more information.
+<P>In some versions of Unix retrieving a value from the current
+ process may require a non-trivial amount of computation.
+We recommend that a dynamically-loaded file contain a single initialization
+ procedure that creates shared bindings for the values exported by the file.
+<H1><A NAME="11">Compatibility</A></H1>
+<P>Scheme&nbsp;48's old <CODE>external-call</CODE> function is still available in the structure
+ <CODE>externals</CODE>, which now also includes <CODE>external-name</CODE> and
+ <CODE>external-value</CODE>.
+The old <CODE>scheme48.h</CODE> file has been renamed <CODE>old-scheme48.h</CODE>.
+<H1><A NAME="12">Accessing Scheme data from C</A></H1>
+
+<P>The C header file <CODE>scheme48.h</CODE> provides
+ access to Scheme&nbsp;48 data structures
+ (for compatibility, the old <CODE>scheme48.h</CODE> file is available
+ as <CODE>old-scheme48.h</CODE>).
+The type <CODE>s48_value</CODE> is used for Scheme values.
+When the type of a value is known, such as the integer returned
+ by <CODE>vector-length</CODE> or the boolean returned by <CODE>pair?</CODE>,
+ the corresponding C procedure returns a C value of the appropriate
+ type, and not a <CODE>s48_value</CODE>.
+Predicates return <CODE>1</CODE> for true and <CODE>0</CODE> for false.
+<H2><A NAME="13">Constants</A></H2>
+
+<P>The following macros denote Scheme constants:
+<DL><DT><B><CODE>S48_FALSE</CODE></B><DD> is <CODE>#f</CODE>.
+<DT><B><CODE>S48_TRUE</CODE></B><DD> is <CODE>#t</CODE>.
+<DT><B><CODE>S48_NULL</CODE></B><DD> is the empty list.
+<DT><B><CODE>S48_UNSPECIFIC</CODE></B><DD> is a value used for functions which have no
+  meaningful return value
+ (in Scheme this value returned by the nullary procedure <CODE>unspecific</CODE>
+ in the structure <CODE>util</CODE>).
+<DT><B><CODE>S48_EOF</CODE></B><DD> is the end-of-file object
+ (in Scheme this value is returned by the nullary procedure <CODE>eof-object</CODE>
+ in the structure <CODE>i/o-internal</CODE>).
+</DL>
+<H2><A NAME="14">Converting values</A></H2>
+<P>The following functions convert values between Scheme and C
+ representations.
+The `extract' ones convert from Scheme to C and the `enter's go the other
+ way.
+<UL><LI><CODE>unsigned char s48_extract_char(s48_value)</CODE>
+<LI><CODE>char *    s48_extract_string(s48_value)</CODE>
+<LI><CODE>long      s48_extract_integer(s48_value)</CODE>
+<LI><CODE>double    s48_extract_double(s48_value)</CODE>
+<LI><CODE>s48_value s48_enter_char(unsigned char)</CODE>
+<LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
+<tr> <td><CODE>s48_value s48_enter_string(char *)</CODE></td> <td align=right>(may GC)</td></tr></table>
+<LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
+<tr> <td><CODE>s48_value s48_enter_integer(long)</CODE></td> <td align=right>(may GC)</td></tr></table>
+<LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
+<tr> <td><CODE>s48_value s48_enter_double(double)</CODE></td> <td align=right>(may GC)</td></tr></table>
+</UL>
+<P>The value returned by <CODE>s48_extract_string</CODE> points to the actual
+ storage used by the string; it is valid only until the next
+ <A HREF="#gc">garbage collection</A>.
+<P><CODE>s48_enter_integer()</CODE> needs to allocate storage when
+ its argument is too large to fit in a Scheme&nbsp;48 fixnum.
+In cases where the number is known to fit within a fixnum (currently 30 bits
+ including the sign), the following procedures can be used.
+These have the disadvantage of only having a limited range, but
+ the advantage of never causing a garbage collection.
+<UL><LI><CODE>long      s48_extract_fixnum(s48_value)</CODE>
+<LI><CODE>s48_value s48_enter_fixnum(long)</CODE>
+<LI><CODE>long      S48_MAX_FIXNUM_VALUE</CODE>
+<LI><CODE>long      S48_MIN_FIXNUM_VALUE</CODE>
+</UL>
+<P>An error is signalled if <CODE>s48_extract_fixnum</CODE>'s argument
+ is not a fixnum or if the argument to <CODE>s48_enter_fixnum</CODE> is less than
+ <CODE>S48_MIN_FIXNUM_VALUE</CODE> or greater than <CODE>S48_MAX_FIXNUM_VALUE</CODE>
+ (<I>-2<sup>29</sup></I> and <I>2<sup>29</sup>-1</I> in the current system).
+<H2><A NAME="15">C versions of Scheme procedures</A></H2>
+<P>The following macros and procedures are C versions of Scheme procedures.
+The names were derived by replacing `<CODE>-</CODE>' with `<CODE>_</CODE>',
+ `<CODE>?</CODE>' with `<CODE>p</CODE>', and dropping `<CODE>!</CODE>.
+<UL><LI><CODE>int       S48_EQ_P(s48_value)</CODE>
+<LI><CODE>int       S48_CHAR_P(s48_value)</CODE>
+<LI><CODE>int       S48_INTEGER_P(s48_value)</CODE>
+</UL>
+<UL><LI><CODE>int       S48_PAIR_P(s48_value)</CODE>
+<LI><CODE>s48_value S48_CAR(s48_value)</CODE>
+<LI><CODE>s48_value S48_CDR(s48_value)</CODE>
+<LI><CODE>void      S48_SET_CAR(s48_value, s48_value)</CODE>
+<LI><CODE>void      S48_SET_CDR(s48_value, s48_value)</CODE>
+<LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
+<tr> <td><CODE>s48_value s48_cons(s48_value, s48_value)</CODE></td> <td align=right>(may GC)</td></tr></table>
+<LI><CODE>long      s48_length(s48_value)</CODE> 
+</UL>
+<UL><LI><CODE>int       S48_VECTOR_P(s48_value)</CODE> 
+<LI><CODE>long      S48_VECTOR_LENGTH(s48_value)</CODE> 
+<LI><CODE>s48_value S48_VECTOR_REF(s48_value, long)</CODE> 
+<LI><CODE>void      S48_VECTOR_SET(s48_value, long, s48_value)</CODE> 
+<LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
+<tr> <td><CODE>s48_value s48_make_vector(long, s48_value)</CODE></td> <td align=right>(may GC)</td></tr></table>
+</UL>
+<UL><LI><CODE>int       S48_STRING_P(s48_value)</CODE> 
+<LI><CODE>long      S48_STRING_LENGTH(s48_value)</CODE> 
+<LI><CODE>char      S48_STRING_REF(s48_value, long)</CODE> 
+<LI><CODE>void      S48_STRING_SET(s48_value, long, char)</CODE> 
+<LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
+<tr> <td><CODE>s48_value s48_make_string(long, char)</CODE></td> <td align=right>(may GC)</td></tr></table>
+</UL>
+<UL><LI><CODE>int       S48_SYMBOL_P(s48_value)</CODE> 
+<LI><CODE>s48_value s48_SYMBOL_TO_STRING(s48_value)</CODE> 
+</UL>
+<UL><LI><CODE>int       S48_BYTE_VECTOR_P(s48_value)</CODE> 
+<LI><CODE>long      S48_BYTE_VECTOR_LENGTH(s48_value)</CODE> 
+<LI><CODE>char      S48_BYTE_VECTOR_REF(s48_value, long)</CODE> 
+<LI><CODE>void      S48_BYTE_VECTOR_SET(s48_value, long, int)</CODE> 
+<LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
+<tr> <td><CODE>s48_value s48_make_byte_vector(long, int)</CODE></td> <td align=right>(may GC)</td></tr></table>
+</UL>
+<H1><A NAME="16">Calling Scheme functions from C</A></H1>
+
+<P>External code that has been called from Scheme can call back to Scheme
+ procedures using the following function.
+<UL><LI><CODE>scheme_value s48_call_scheme(s48_value proc, long nargs, ...)</CODE>
+</UL>
+This calls the Scheme procedure <CODE>proc</CODE> on <CODE>nargs</CODE>
+ arguments, which are passed as additional arguments to <CODE>s48_call_scheme</CODE>.
+There may be at most ten arguments.
+The value returned by the Scheme procedure is returned by the C procedure.
+Invoking any Scheme procedure may potentially cause a garbage collection.
+<P>There are some complications that occur when mixing calls from C to Scheme
+ with continuations and threads.
+C only supports downward continuations (via <CODE>longjmp()</CODE>).
+Scheme continuations that capture a portion of the C stack have to follow the
+ same restriction.
+For example, suppose Scheme procedure <CODE>s0</CODE> captures continuation <CODE>a</CODE>
+ and then calls C procedure <CODE>c0</CODE>, which in turn calls Scheme procedure
+ <CODE>s1</CODE>.
+Procedure <CODE>s1</CODE> can safely call the continuation <CODE>a</CODE>, because that
+ is a downward use.
+When <CODE>a</CODE> is called Scheme&nbsp;48 will remove the portion of the C stack used
+ by the call to <CODE>c0</CODE>.
+On the other hand, if <CODE>s1</CODE> captures a continuation, that continuation
+ cannot be used from <CODE>s0</CODE>, because by the time control returns to
+ <CODE>s0</CODE> the C stack used by <CODE>c0</CODE> will no longer be valid.
+An attempt to invoke an upward continuation that is closed over a portion
+ of the C stack will raise an exception.
+<P>In Scheme&nbsp;48 threads are implemented using continuations, so the downward
+ restriction applies to them as well.
+An attempt to return from Scheme to C at a time when the appropriate
+ C frame is not on top of the C stack will cause the current thread to
+ block until the frame is available.
+For example, suppose thread <CODE>t0</CODE> calls a C procedure which calls back
+ to Scheme, at which point control switches to thread <CODE>t1</CODE>, which also
+ calls C and then back to Scheme.
+At this point both <CODE>t0</CODE> and <CODE>t1</CODE> have active calls to C on the
+ C stack, with <CODE>t1</CODE>'s C frame above <CODE>t0</CODE>'s.
+If thread <CODE>t0</CODE> attempts to return from Scheme to C it will block,
+ as its frame is not accessable.
+Once <CODE>t1</CODE> has returned to C and from there to Scheme, <CODE>t0</CODE> will
+ be able to resume.
+The return to Scheme is required because context switches can only occur while
+ C code is running.
+<CODE>T0</CODE> will also be able to resume if <CODE>t1</CODE> uses a continuation to
+ throw past its call to C.
+<H1><A NAME="gc">Interacting with the Scheme Heap</A></H1>
+
+
+<P>Scheme&nbsp;48 uses a copying, precise garbage collector.
+Any procedure that allocates objects within the Scheme&nbsp;48 heap may trigger
+ a garbage collection.
+Variables bound to values in the Scheme&nbsp;48 heap need to be registered with
+ the garbage collector so that the value will be retained and so that the
+ variables will be updated if the garbage collector moves the object.
+The garbage collector has no facility for updating pointers to the interiors
+ of objects, so such pointers, for example the ones returned by
+ <CODE>EXTRACT_STRING</CODE>, will likely become invalid when a garbage collection
+ occurs.
+<H2><A NAME="18">Registering Objects with the GC</A></H2>
+
+<P>A set of macros are used to manage the registration of local variables with the
+ garbage collector.
+<UL><LI><CODE>S48_DECLARE_GC_PROTECT(<I>n</I>)</CODE>
+<LI><CODE>void S48_GC_PROTECT_<I>n</I>(s48_value<I><sub>1</sub></I>, <I>...</I>, s48_value<I><sub>n</sub></I>)</CODE>
+<LI><CODE>void S48_GC_UNPROTECT()</CODE>
+</UL>
+<P><CODE>S48_DECLARE_GC_PROTECT(<I>n</I>)</CODE>, where  <I>1 &lt;= n &lt;= 9</I>, allocates
+ storage for registering <I>n</I> variables.
+At most one use of <CODE>S48_DECLARE_GC_PROTECT</CODE> may occur in a block.
+<CODE>S48_GC_PROTECT_<I>n</I>(<I>v<sub>1</sub></I>, <I>...</I>, <I>v<sub>n</sub></I>)</CODE> registers the
+ <I>n</I> variables (l-values) with the garbage collector.
+It must be within scope of a <CODE>S48_DECLARE_GC_PROTECT(<I>n</I>)</CODE>
+ and be before any code which can cause a GC.
+<CODE>S48_GC_UNPROTECT</CODE> removes the block's protected variables from
+ the garbage collectors list.
+It must be called at the end of the block after 
+  any code which may cause a garbage collection.
+Omitting any of the three may cause serious and
+ hard-to-debug problems.
+Notably, the garbage collector may relocate an object and
+ invalidate <CODE>s48_value</CODE> variables which are not protected.
+<P>A <CODE>gc-protection-mismatch</CODE> exception is raised if, when a C
+ procedure returns to Scheme, the calls
+ to <CODE>S48_GC_PROTECT()</CODE> have not been matched by an equal number of
+ calls to <CODE>S48_GC_UNPROTECT()</CODE>.
+<P>Global variables may also be registered with the garbage collector.
+<UL><LI><CODE>void S48_GC_PROTECT_GLOBAL(<CODE><I>value</I></CODE>)</CODE>
+</UL>
+<P><CODE>S48_GC_PROTECT_GLOBAL</CODE> permanently registers the
+  variable <CODE><I>value</I></CODE> (an l-value) with the garbage collector.
+There is no way to unregister the variable.
+<H2><A NAME="19">Keeping C data structures in the Scheme heap</A></H2>
+
+<P>C data structures can be kept in the Scheme heap by embedding them
+ inside byte vectors.
+The following macros can be used to create and access embedded C objects.
+<UL><LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
+<tr> <td><CODE>s48_value S48_MAKE_VALUE(type)</CODE></td> <td align=right>(may GC)</td></tr></table>
+<LI><CODE>type      S48_EXTRACT_VALUE(s48_value, type)</CODE>
+<LI><CODE>type *    S48_EXTRACT_VALUE_POINTER(s48_value, type)</CODE>
+<LI><CODE>void      S48_SET_VALUE(s48_value, type, value)</CODE>
+</UL>
+<P><CODE>S48_MAKE_VALUE</CODE> makes a byte vector large enough to hold an object
+ whose type is <CODE><I>type</I></CODE>.
+<CODE>S48_EXTRACT_VALUE</CODE> returns the contents of a byte vector cast to
+ <CODE><I>type</I></CODE>, and <CODE>S48_EXTRACT_VALUE_POINTER</CODE> returns a pointer
+ to the contents of the byte vector.
+The value returned by <CODE>S48_EXTRACT_VALUE_POINTER</CODE> is valid only until
+ the next <A HREF="#gc">garbage collection</A>.
+<P><CODE>S48_SET_VALUE</CODE> stores <CODE>value</CODE> into the byte vector.
+<H2><A NAME="20">C code and heap images</A></H2>
+
+<P>Scheme&nbsp;48 uses dumped heap images to restore a previous system state.
+The Scheme&nbsp;48 heap is written into a file in a machine-independent and
+ operating-system-independent format.
+The procedures described above may be used to create objects in the
+ Scheme heap that contain information specific to the current
+ machine, operating system, or process.
+A heap image containing such objects may not work correctly on
+ when resumed.
+<P>To address this problem, a record type may be given a `resumer'
+ procedure.
+On startup, the resumer procedure for a type is applied to each record of
+ that type in the image being restarted.
+This procedure can update the record in a manner appropriate to
+ the machine, operating system, or process used to resume the
+ image.
+<UL><LI><CODE>(define-record-resumer<I>&nbsp;record-type&nbsp;procedure</I>)</CODE>
+</UL>
+<P><CODE>Define-record-resumer</CODE> defines <CODE><I>procedure</I></CODE>,
+ which should accept one argument, to be the resumer for
+ <I>record-type</I>.
+The order in which resumer procedures are called is not specified.
+<P>The <CODE><I>procedure</I></CODE> argument to <CODE>define-record-resumer</CODE> may
+ be <CODE>#f</CODE>, in which case records of the given type are
+ not written out in heap images.
+When writing a heap image any reference to such a record is replaced by
+ the value of the record's first field, and an exception is raised
+ after the image is written.
+<H1><A NAME="21">Using Scheme records in C code</A></H1>
+<P>External modules can create records and access their slots
+ positionally.
+<UL><LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
+<tr> <td><CODE>s48_value S48_MAKE_RECORD(s48_value)</CODE></td> <td align=right>(may GC)</td></tr></table>
+<LI><CODE>int       S48_RECORD_P(s48_value)</CODE> 
+<LI><CODE>s48_value S48_RECORD_TYPE(s48_value)</CODE> 
+<LI><CODE>s48_value S48_RECORD_REF(s48_value, long)</CODE> 
+<LI><CODE>void      S48_RECORD_SET(s48_value, long, s48_value)</CODE> 
+</UL>
+The argument to <CODE>S48_MAKE_RECORD</CODE> should be a shared binding
+ whose value is a record type.
+In C the fields of Scheme records are only accessible via offsets,
+ with the first field having offset zero, the second offset one, and
+ so forth.
+If the order of the fields is changed in the Scheme definition of the
+ record type the C code must be updated as well.
+<P>For example, given the following record-type definition
+<BLOCKQUOTE><PRE>
+(define-record-type thing :thing
+  (make-thing a b)
+  thing?
+  (a thing-a)
+  (b thing-b))
+</PRE></BLOCKQUOTE>
+the identifier <CODE>:thing</CODE> is bound to the record type and can
+ be exported to C:
+<BLOCKQUOTE><PRE>
+(define-exported-binding "thing-record-type" :thing)
+</PRE></BLOCKQUOTE>
+<CODE>Thing</CODE> records can then be made in C:
+<BLOCKQUOTE><PRE>
+static scheme_value thing_record_type_binding = SCHFALSE;
+
+void initialize_things(void)
+{
+  S48_GC_PROTECT_GLOBAL(thing_record_type_binding);
+  thing_record_type_binding =
+     s48_get_imported_binding("thing-record-type");
+}
+
+scheme_value make_thing(scheme_value a, scheme_value b)
+{
+  s48_value thing;
+  s48_DECLARE_GC_PROTECT(2);
+
+  S48_GC_PROTECT_2(a, b);
+
+  thing = s48_make_record(thing_record_type_binding);
+  S48_RECORD_SET(thing, 0, a);
+  S48_RECORD_SET(thing, 1, b);
+
+  S48_GC_UNPROTECT();
+
+  return thing;
+}
+</PRE></BLOCKQUOTE>
+Note that the variables <CODE>a</CODE> and <CODE>b</CODE> must be protected
+ against the possibility of a garbage collection occuring during
+ the call to <CODE>s48_make_record()</CODE>.
+<H1><A NAME="22">Raising exceptions from external code</A></H1>
+
+<P>The following macros explicitly raise certain errors, immediately
+ returning to Scheme&nbsp;48.
+Raising an exception performs all
+ necessary clean-up actions to properly return to Scheme&nbsp;48, including
+ adjusting the stack of protected variables.
+<UL><LI><CODE>s48_raise_scheme_exception(int type, int nargs, ...)</CODE>
+</UL>
+<P><CODE>s48_raise_scheme_exception</CODE> is the base procedure for
+ raising exceptions.
+<CODE>type</CODE> is the type of exception, and should be one of the
+ <CODE>S48_EXCEPTION_</CODE>...constants defined in <CODE>scheme48arch.h</CODE>.
+<CODE>nargs</CODE> is the number of additional values to be included in the
+ exception; these follow the <CODE>nargs</CODE> argument and should all have
+ type <CODE>s48_value</CODE>.
+<CODE>s48_raise_scheme_exception</CODE> never returns.
+<P>The following procedures are available for raising particular
+ types of exceptions.
+Like <CODE>s48_raise_scheme_exception</CODE> these never return.
+<UL><LI><CODE>s48_raise_argument_type_error(scheme_value)</CODE>
+<LI><CODE>s48_raise_argument_number_error(int nargs, int min, int max)</CODE>
+<LI><CODE>s48_raise_index_range_error(long value, long min, long max)</CODE>
+<LI><CODE>s48_raise_closed_channel_error()</CODE>
+<LI><CODE>s48_raise_os_error(int errno)</CODE>
+<LI><CODE>s48_raise_out_of_memory_error()</CODE>
+</UL>
+<P>An argument type error indicates that the given value is of the wrong
+ type.
+An argument number error is raised when the number of arguments, <CODE>nargs</CODE>,
+ should be, but isn't, between <CODE>min</CODE> and <CODE>max</CODE>, inclusive.
+Similarly, and index range error is raised when <CODE>value</CODE> is not between
+ between <CODE>min</CODE> and <CODE>max</CODE>, inclusive.
+<P>The following macros raise argument type errors if their argument does not
+ have the required type.
+<UL><LI><CODE>void S48_CHECK_SYMBOL(s48_value)</CODE>
+<LI><CODE>void S48_CHECK_PAIR(s48_value)</CODE>
+<LI><CODE>void S48_CHECK_STRING(s48_value)</CODE>
+<LI><CODE>void S48_CHECK_INTEGER(s48_value)</CODE>
+<LI><CODE>void S48_CHECK_CHANNEL(s48_value)</CODE>
+<LI><CODE>void S48_CHECK_BYTE_VECTOR(s48_value)</CODE>
+<LI><CODE>void S48_CHECK_RECORD(s48_value)</CODE>
+<LI><CODE>void S48_CHECK_SHARED_BINDING(s48_value)</CODE>
+</UL>
+<H1><A NAME="23">Unsafe functions and macros</A></H1>
+<P>All of the C procedures and macros described above check that their
+ arguments have the appropriate types and that indexes are in range.
+The following procedures and macros are identical to those described
+ above, except that they do not perform type and range checks.
+They are provided for the purpose of writing more efficient code;
+ their general use is not recommended.
+<UL><LI><CODE>char      S48_UNSAFE_EXTRACT_CHAR(s48_value)</CODE>
+<LI><CODE>char *    S48_UNSAFE_EXTRACT_STRING(s48_value)</CODE>
+<LI><CODE>long      S48_UNSAFE_EXTRACT_INTEGER(s48_value)</CODE>
+<LI><CODE>long      S48_UNSAFE_EXTRACT_DOUBLE(s48_value)</CODE>
+</UL>
+<UL><LI><CODE>long      S48_UNSAFE_EXTRACT_FIXNUM(s48_value)</CODE>
+<LI><CODE>s48_value S48_UNSAFE_ENTER_FIXNUM(long)</CODE>
+</UL>
+<UL><LI><CODE>s48_value S48_UNSAFE_CAR(s48_value)</CODE>
+<LI><CODE>s48_value S48_UNSAFE_CDR(s48_value)</CODE>
+<LI><CODE>void      S48_UNSAFE_SET_CAR(s48_value, s48_value)</CODE>
+<LI><CODE>void      S48_UNSAFE_SET_CDR(s48_value, s48_value)</CODE>
+</UL>
+<UL><LI><CODE>long      S48_UNSAFE_VECTOR_LENGTH(s48_value)</CODE> 
+<LI><CODE>s48_value S48_UNSAFE_VECTOR_REF(s48_value, long)</CODE> 
+<LI><CODE>void      S48_UNSAFE_VECTOR_SET(s48_value, long, s48_value)</CODE> 
+</UL>
+<UL><LI><CODE>long      S48_UNSAFE_STRING_LENGTH(s48_value)</CODE> 
+<LI><CODE>char      S48_UNSAFE_STRING_REF(s48_value, long)</CODE> 
+<LI><CODE>void      S48_UNSAFE_STRING_SET(s48_value, long, char)</CODE> 
+</UL>
+<UL><LI><CODE>s48_value S48_UNSAFE_SYMBOL_TO_STRING(s48_value)</CODE> 
+</UL>
+<UL><LI><CODE>long      S48_UNSAFE_BYTE_VECTOR_LENGTH(s48_value)</CODE> 
+<LI><CODE>char      S48_UNSAFE_BYTE_VECTOR_REF(s48_value, long)</CODE> 
+<LI><CODE>void      S48_UNSAFE_BYTE_VECTOR_SET(s48_value, long, int)</CODE> 
+</UL>
+<UL><LI><CODE>s48_value S48_UNSAFE_SHARED_BINDING_REF(s48_value s_b)</CODE>
+<LI><CODE>int       S48_UNSAFE_SHARED_BINDING_P(x)</CODE>
+<LI><CODE>int       S48_UNSAFE_SHARED_BINDING_IS_IMPORT_P(s48_value s_b)</CODE>
+<LI><CODE>s48_value S48_UNSAFE_SHARED_BINDING_NAME(s48_value s_b)</CODE>
+<LI><CODE>void      S48_UNSAFE_SHARED_BINDING_SET(s48_value s_b, s48_value value)</CODE>
+</UL>
+<UL><LI><CODE>s48_value S48_UNSAFE_RECORD_TYPE(s48_value)</CODE> 
+<LI><CODE>s48_value S48_UNSAFE_RECORD_REF(s48_value, long)</CODE> 
+<LI><CODE>void      S48_UNSAFE_RECORD_SET(s48_value, long, s48_value)</CODE> 
+</UL>
+<UL><LI><CODE>type      S48_UNSAFE_EXTRACT_VALUE(s48_value, type)</CODE>
+<LI><CODE>type *    S48_UNSAFE_EXTRACT_VALUE_POINTER(s48_value, type)</CODE>
+<LI><CODE>void      S48_UNSAFE_SET_VALUE(s48_value, type, value)</CODE>
+</UL>
+<HR ><ADDRESS><a href="http://www-pu.informatik.uni-tuebingen.de/users/sperber/">Mike
+  Sperber</a>, <a href="http://www.neci.nj.nec.com/homepages/kelsey/">Richard Kelsey</a></ADDRESS><BR>
+</BODY></HTML>
diff --git a/doc/html/utilities.html b/doc/html/utilities.html
new file mode 100644
index 0000000..5e40725
--- /dev/null
+++ b/doc/html/utilities.html
@@ -0,0 +1,315 @@
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2 Final//EN">
+<HTML>
+<!-- HTML file produced from file: utilities.tex --
+ -- using Hyperlatex v 2.3.1 (c) Otfried Cheong--
+ -- on Emacs 19.34.1, Tue Feb 23 18:25:11 1999 -->
+<HEAD>
+<TITLE>Untitled</TITLE>
+
+</HEAD><BODY>
+
+
+    <H1 ALIGN=CENTER>Scheme 48 User's Guide</H1>
+    <H2 ALIGN=CENTER>Richard A. Kelsey</H2>
+    <H3 ALIGN=CENTER>February 23, 1999</H3>
+    <H1><A NAME="1">ASCII character encoding</A></H1>
+<P>These are in the structure <CODE>ascii</CODE>.
+<UL><LI><CODE>(char-&gt;ascii<VAR> char</VAR>)&nbsp;-&gt;&nbsp;<VAR>integer</VAR></CODE>
+<LI><CODE>(ascii-&gt;char<VAR> integer</VAR>)&nbsp;-&gt;&nbsp;<VAR>char</VAR></CODE>
+</UL>
+These are identical to <CODE>char-&gt;integer</CODE> and <CODE>integer-&gt;char</CODE> except that
+ they use the ASCII encoding.
+<UL><LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
+<tr> <td><CODE>ascii-limit</CODE></td> <td align=right>integer</td></tr></table>
+<LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
+<tr> <td><CODE>ascii-whitespaces</CODE></td> <td align=right>list of integers</td></tr></table>
+</UL>
+<CODE>Ascii-limit</CODE> is one more than the largest value that <CODE>char-&gt;ascii</CODE>
+ may return.
+<CODE>Ascii-whitespaces</CODE> is a list of the ASCII values of whitespace characters
+ (space, tab, line feed, form feed, and carriage return).
+<H1><A NAME="2">Bitwise integer operations</A></H1>
+<P>These functions use the two's-complement representation for integers.
+There is no limit to the number of bits in an integer.
+They are in the structures <CODE>bitwise</CODE> and <CODE>big-scheme</CODE>.
+<UL><LI><CODE>(bitwise-and<VAR> integer integer</VAR>)&nbsp;-&gt;&nbsp;<VAR>integer</VAR></CODE>
+<LI><CODE>(bitwise-ior<VAR> integer integer</VAR>)&nbsp;-&gt;&nbsp;<VAR>integer</VAR></CODE>
+<LI><CODE>(bitwise-xor<VAR> integer integer</VAR>)&nbsp;-&gt;&nbsp;<VAR>integer</VAR></CODE>
+<LI><CODE>(bitwise-not<VAR> integer</VAR>)&nbsp;-&gt;&nbsp;<VAR>integer</VAR></CODE>
+</UL>
+These perform various logical operations on integers on a bit-by-bit
+basis. `<CODE>ior</CODE>' is inclusive OR and `<CODE>xor</CODE>' is exclusive OR.
+<UL><LI><CODE>(arithmetic-shift<VAR> integer bit-count</VAR>)&nbsp;-&gt;&nbsp;<VAR>integer</VAR></CODE>
+</UL>
+Shifts the integer by the given bit count, which must be an integer,
+ shifting left for positive counts and right for negative ones.
+Shifting preserves the integer's sign.
+<H1><A NAME="3">Arrays</A></H1>
+<P>These are N-dimensional, zero-based arrays and
+ are in the structure <CODE>arrays</CODE>.
+<P>The array interface is derived from one written by Alan Bawden.
+<UL><LI><CODE>(make-array<VAR> value dimension<I><sub>0</sub></I> ...</VAR>)&nbsp;-&gt;&nbsp;<VAR>array</VAR></CODE>
+<LI><CODE>(array<VAR> dimensions element<I><sub>0</sub></I> ...</VAR>)&nbsp;-&gt;&nbsp;<VAR>array</VAR></CODE>
+<LI><CODE>(copy-array<VAR> array</VAR>)&nbsp;-&gt;&nbsp;<VAR>array</VAR></CODE>
+</UL>
+<CODE>Make-array</CODE> makes a new array with the given dimensions, each of which
+ must be a non-negative integer.
+Every element is initially set to <CODE><VAR>value</VAR></CODE>.
+<CODE>Array</CODE> Returns a new array with the given dimensions and elements.
+<CODE><VAR>Dimensions</VAR></CODE> must be a list of non-negative integers, 
+The number of elements should be the equal to the product of the
+ dimensions.
+The elements are stored in row-major order.
+<BLOCKQUOTE><PRE>
+(make-array 'a 2 3) <CODE>-&gt;</CODE> {Array 2 3}
+
+(array '(2 3) 'a 'b 'c 'd 'e 'f)
+    <CODE>-&gt;</CODE> {Array 2 3}
+</PRE></BLOCKQUOTE>
+<P><CODE>Copy-array</CODE> returns a copy of <CODE><VAR>array</VAR></CODE>.
+The copy is identical to the <CODE><VAR>array</VAR></CODE> but does not share storage with it.
+<UL><LI><CODE>(array?<VAR> value</VAR>)&nbsp;-&gt;&nbsp;<VAR>boolean</VAR></CODE>
+</UL>
+Returns <CODE>#t</CODE> if <CODE><VAR>value</VAR></CODE> is an array.
+<UL><LI><CODE>(array-ref<VAR> array index<I><sub>0</sub></I> ...</VAR>)&nbsp;-&gt;&nbsp;<VAR>value</VAR></CODE>
+<LI><CODE>(array-set!<VAR> array value index<I><sub>0</sub></I> ...</VAR>)</CODE>
+<LI><CODE>(array-&gt;vector<VAR> array</VAR>)&nbsp;-&gt;&nbsp;<VAR>vector</VAR></CODE>
+<LI><CODE>(array-dimensions<VAR> array</VAR>)&nbsp;-&gt;&nbsp;<VAR>list</VAR></CODE>
+</UL>
+<CODE>Array-ref</CODE> returns the specified array element and <CODE>array-set!</CODE>
+ replaces the element with <CODE><VAR>value</VAR></CODE>.
+<BLOCKQUOTE><PRE>
+(let ((a (array '(2 3) 'a 'b 'c 'd 'e 'f)))
+  (let ((x (array-ref a 0 1)))
+    (array-set! a 'g 0 1)
+    (list x (array-ref a 0 1))))
+    <CODE>-&gt;</CODE> '(b g)
+</PRE></BLOCKQUOTE>
+<P><CODE>Array-&gt;vector</CODE> returns a vector containing the elements of <CODE><VAR>array</VAR></CODE>
+ in row-major order.
+<CODE>Array-dimensions</CODE> returns the dimensions of
+ the array as a list.
+<UL><LI><CODE>(make-shared-array<VAR> array linear-map dimension<I><sub>0</sub></I> ...</VAR>)&nbsp;-&gt;&nbsp;<VAR>array</VAR></CODE>
+</UL>
+<CODE>Make-shared-array</CODE> makes a new array that shares storage with <CODE><VAR>array</VAR></CODE>
+ and uses <CODE><VAR>linear-map</VAR></CODE> to map indicies to elements.
+<CODE><VAR>Linear-map</VAR></CODE> must accept as many arguments as the number of
+ <CODE><VAR>dimension</VAR></CODE>s given and must return a list of non-negative integers
+ that are valid indicies into <CODE><VAR>array</VAR></CODE>.
+<BLOCKQUOTE><PRE>
+(array-ref (make-shared-array a f i0 i1 ...)
+           j0 j1 ...)
+</PRE></BLOCKQUOTE>
+is equivalent to
+<BLOCKQUOTE><PRE>
+(apply array-ref a (f j0 j1 ...))
+</PRE></BLOCKQUOTE>
+<P>As an example, the following function makes the transpose of a two-dimensional
+ array:
+<BLOCKQUOTE><PRE>
+(define (transpose array)
+  (let ((dimensions (array-dimensions array)))
+    (make-shared-array array
+                       (lambda (x y)
+		         (list y x))
+		       (cadr dimensions)
+		       (car dimensions))))
+
+(array-&gt;vector
+  (transpose
+    (array '(2 3) 'a 'b 'c 'd 'e 'f)))
+      <CODE>-&gt;</CODE> '(a d b e c f)
+</PRE></BLOCKQUOTE>
+<H1><A NAME="4">Records</A></H1>
+<P>New types can be constructed using the <CODE>define-record-type</CODE> macro
+ from the <CODE>define-record-types</CODE> structure
+The general syntax is:
+<BLOCKQUOTE><PRE>
+(define-record-type <CODE><VAR>tag</VAR></CODE> <CODE><VAR>type-name</VAR></CODE>
+  (<CODE><VAR>constructor-name</VAR></CODE> <CODE><VAR>field-tag</VAR></CODE> ...)
+  <CODE><VAR>predicate-name</VAR></CODE>
+  (<CODE><VAR>field-tag</VAR></CODE> <CODE><VAR>accessor-name</VAR></CODE> [<CODE><VAR>modifier-name</VAR></CODE>])
+  ...)
+</PRE></BLOCKQUOTE>
+This makes the following definitions:
+<UL><LI><table border=0 cellspacing=0 cellpadding=0 width=80%>
+<tr> <td><CODE><CODE><VAR>type-name</VAR></CODE></CODE></td> <td align=right>type</td></tr></table>
+<LI><CODE>(<CODE><VAR>constructor-name</VAR></CODE><VAR> field-init ...</VAR>)&nbsp;-&gt;&nbsp;<VAR>type-name</VAR></CODE>
+<LI><CODE>(<CODE><VAR>predicate-name</VAR></CODE><VAR> value</VAR>)&nbsp;-&gt;&nbsp;<VAR>boolean</VAR></CODE>
+<LI><CODE>(<CODE><VAR>accessor-name</VAR></CODE><VAR> type-name</VAR>)&nbsp;-&gt;&nbsp;<VAR>value</VAR></CODE>
+<LI><CODE>(<CODE><VAR>modifier-name</VAR></CODE><VAR> type-name value</VAR>)</CODE>
+</UL>
+<CODE><VAR>Type-name</VAR></CODE> is the record type itself, and can be used to
+ specify a print method (see below).
+<CODE><VAR>Constructor-name</VAR></CODE> is a constructor that accepts values
+ for the fields whose tags are specified.
+<CODE><VAR>Predicate-name</VAR></CODE> to a predicate that can returns <CODE>#t</CODE> for
+ elements of the type and <CODE>#f</CODE> for everything else.
+The <CODE><VAR>accessor-name</VAR></CODE>s retrieve the values of fields,
+ and the <CODE><VAR>modifier-name</VAR></CODE>'s update them.
+The <CODE><VAR>tag</VAR></CODE> is used in printing instances of the record type and
+ the field tags are used in the inspector and to match
+ constructor arguments with fields.
+<UL><LI><CODE>(define-record-discloser<VAR> type discloser</VAR>)</CODE>
+</UL>
+<CODE>Define-record-discloser</CODE> determines how
+ records of type <CODE><VAR>type</VAR></CODE> are printed.
+<CODE><VAR>Discloser</VAR></CODE> should be procedure which takes a single
+ record of type <CODE><VAR>type</VAR></CODE> and returns a list whose car is
+ a symbol.
+The record will be printed as the value returned by <CODE><VAR>discloser</VAR></CODE>
+ with curly braces used instead of the usual parenthesis.
+<P>For example
+<BLOCKQUOTE><PRE>
+(define-record-type pare :pare
+  (kons x y)
+  pare?
+  (x kar set-kar!)
+  (y kdr))
+</PRE></BLOCKQUOTE>
+defines <CODE>kons</CODE> to be a constructor, <CODE>kar</CODE> and <CODE>kdr</CODE> to be
+ accessors, <CODE>set-kar!</CODE> to be a modifier, and <CODE>pare?</CODE> to be a predicate
+ for a new type of object.
+The type itself is named <CODE>:pare</CODE>.
+<CODE>Pare</CODE> is a tag used in printing the new objects.
+<P>By default, the new objects print as <CODE>#Pare</CODE>.
+The print method can be modified using DEFINE-RECORD-DISCLOSER:
+<BLOCKQUOTE><PRE>
+(define-record-discloser :pare
+  (lambda (p) `(pare ,(kar p) ,(kdr p))))
+</PRE></BLOCKQUOTE>
+will cause the result of <CODE>(kons 1 2)</CODE> to print as
+ <CODE>#{pare 1 2}</CODE>.
+<H1><A NAME="5">Finite record types</A></H1>
+<P>The structure <CODE>finite-types</CODE> has
+ two macros for defining `finite' record types.
+These are record types for which there are a fixed number of instances,
+ which are created when the record type is defined.
+The syntax for the defining a finite type is:
+<BLOCKQUOTE><PRE>
+(define-finite-type <CODE><VAR>tag</VAR></CODE> <CODE><VAR>type-name</VAR></CODE>
+  (<CODE><VAR>field-tag</VAR></CODE> ...)
+  <CODE><VAR>predicate-name</VAR></CODE>
+  <CODE><VAR>vector-of-elements-name</VAR></CODE>
+  <CODE><VAR>name-accessor</VAR></CODE>
+  <CODE><VAR>index-accessor</VAR></CODE>
+  (<CODE><VAR>field-tag</VAR></CODE> <CODE><VAR>accessor-name</VAR></CODE> [<CODE><VAR>modifier-name</VAR></CODE>])
+  ...
+  ((<CODE><VAR>element-name</VAR></CODE> <CODE><VAR>field-value</VAR></CODE> ...)
+   ...))
+</PRE></BLOCKQUOTE>
+This differs from <CODE>define-record-type</CODE> in the following ways:
+<UL><LI>No name is specified for the constructor, but the field arguments
+ to the constructor are listed.
+<LI>The <CODE><VAR>vector-of-elements-name</VAR></CODE> is added; it will be bound
+ to a vector containing all of the elements of the type.
+These are constructed by applying the (unnamed) constructor to the
+ initial field values at the end of the form.
+<LI>There are names for accessors for two required fields, name
+ and index.
+These fields are not settable, and are not to be included
+ in the argument list for the constructor.
+<LI>The form ends with the names and the initial field values for
+ the elements of the type.
+The name must be first.
+The remaining values must match the <CODE><VAR>field-tag</VAR></CODE>s in the constructor's
+ argument list.
+<LI><CODE><VAR>Tag</VAR></CODE> is bound to a macro that maps <CODE><VAR>element-name</VAR></CODE>s to the
+ the corresponding element of the vector.
+The name lookup is done at macro-expansion time.
+</UL>
+<BLOCKQUOTE><PRE>
+(define-finite-type color :color
+  (red green blue)
+  color?
+  colors
+  color-name
+  color-index
+  (red   color-red)
+  (green color-green)
+  (blue  color-blue)
+  ((white  255 255 255)
+   (black    0   0   0)
+   (yellow 255 255   0)
+   (maroon 176  48  96)))
+
+(color-name (vector-ref colors 0)) <CODE>-&gt;</CODE> white
+(color-name (color black))         <CODE>-&gt;</CODE> black
+(color-index (color yellow))       <CODE>-&gt;</CODE> 2
+(color-red (color maroon))         <CODE>-&gt;</CODE> 176
+</PRE></BLOCKQUOTE>
+<P>Enumerated types are finite types whose only fields are the name
+ and the index.
+The syntax for defining an enumerated type is:
+<BLOCKQUOTE><PRE>
+(define-enumerated-type <CODE><VAR>tag</VAR></CODE> <CODE><VAR>type-name</VAR></CODE>
+  <CODE><VAR>predicate-name</VAR></CODE>
+  <CODE><VAR>vector-of-elements-name</VAR></CODE>
+  <CODE><VAR>name-accessor</VAR></CODE>
+  <CODE><VAR>index-accessor</VAR></CODE>
+  (<CODE><VAR>element-name</VAR></CODE> ...))
+</PRE></BLOCKQUOTE>
+In the absence of any additional fields, both the constructor argument
+ list and the initial field values are not required.
+<P>The above example of a finite type can be pared down to the following
+ enumerated type:
+<BLOCKQUOTE><PRE>
+(define-enumerated-type color :color
+  color?
+  colors
+  color-name
+  color-index
+  (white black yellow maroon))
+
+(color-name (vector-ref colors 0)) <CODE>-&gt;</CODE> white
+(color-name (color black))         <CODE>-&gt;</CODE> black
+(color-index (color yellow))       <CODE>-&gt;</CODE> 2
+</PRE></BLOCKQUOTE>
+<H1><A NAME="6">Hash tables</A></H1>
+<P>These are generic hash tables, and are in the structure <CODE>tables</CODE>.
+Strictly speaking they are more maps than tables, as every table has a
+ value for every possible key (for that type of table).
+All but a finite number of those values are <CODE>#f</CODE>.
+<UL><LI><CODE>(make-table<VAR></VAR>)&nbsp;-&gt;&nbsp;<VAR>table</VAR></CODE>
+<LI><CODE>(make-symbol-table<VAR></VAR>)&nbsp;-&gt;&nbsp;<VAR>symbol-table</VAR></CODE>
+<LI><CODE>(make-string-table<VAR></VAR>)&nbsp;-&gt;&nbsp;<VAR>string-table</VAR></CODE>
+<LI><CODE>(make-integer-table<VAR></VAR>)&nbsp;-&gt;&nbsp;<VAR>integer-table</VAR></CODE>
+<LI><CODE>(make-table-maker<VAR> compare-proc hash-proc</VAR>)&nbsp;-&gt;&nbsp;<VAR>procedure</VAR></CODE>
+<LI><CODE>(make-table-immutable!<VAR> table</VAR>)</CODE>
+</UL>
+The first four functions listed make various kinds of tables.
+<CODE>Make-table</CODE> returns a table whose keys may be symbols, integer,
+ characters, booleans, or the empty list (these are also the values
+ that may be used in <CODE>case</CODE> expressions).
+As with <CODE>case</CODE>, comparison is done using <CODE>eqv?</CODE>.
+The comparison procedures used in symbol, string, and integer tables are
+ <CODE>eq?</CODE>, <CODE>string=?</CODE>, and <CODE>=</CODE>.
+<P><CODE>Make-table-maker</CODE> takes two procedures as arguments and returns
+ a nullary table-making procedure.
+<CODE><VAR>Compare-proc</VAR></CODE> should be a two-argument equality predicate.
+<CODE><VAR>Hash-proc</VAR></CODE> should be a one argument procedure that takes a key
+ and returns a non-negative integer hash value.
+If <CODE>(<CODE><VAR>compare-proc</VAR></CODE> <CODE><VAR>x</VAR></CODE> <CODE><VAR>y</VAR></CODE>)</CODE> returns true,
+ then <CODE>(= (<CODE><VAR>hash-proc</VAR></CODE> <CODE><VAR>x</VAR></CODE>) (<CODE><VAR>hash-proc</VAR></CODE> <CODE><VAR>y</VAR></CODE>))</CODE>
+ must also return true.
+For example, <CODE>make-integer-table</CODE> could be defined
+ as <CODE>(make-table-maker = abs)</CODE>.
+<P><CODE>Make-table-immutable!</CODE> prohibits future modification to its argument.
+<UL><LI><CODE>(table?<VAR> value</VAR>)&nbsp;-&gt;&nbsp;<VAR>boolean</VAR></CODE>
+<LI><CODE>(table-ref<VAR> table key</VAR>)&nbsp;-&gt;&nbsp;<VAR>value or <CODE>#f</CODE></VAR></CODE>
+<LI><CODE>(table-set!<VAR> table key value</VAR>)</CODE>
+<LI><CODE>(table-walk<VAR> procedure table</VAR>)</CODE>
+</UL>
+<CODE>Table?</CODE> is the predicate for tables.
+<CODE>Table-ref</CODE> and <CODE>table-set!</CODE> access and modify the value of <CODE><VAR>key</VAR></CODE>
+ in <CODE><VAR>table</VAR></CODE>.
+<CODE>Table-walk</CODE> applies <CODE><VAR>procedure</VAR></CODE>, which must accept two arguments,
+ to every associated key and non-<CODE>#f</CODE> value in <CODE>table</CODE>.
+<UL><LI><CODE>(default-hash-function<VAR> value</VAR>)&nbsp;-&gt;&nbsp;<VAR>integer</VAR></CODE>
+<LI><CODE>(string-hash<VAR> string</VAR>)&nbsp;-&gt;&nbsp;<VAR>integer</VAR></CODE>
+</UL>
+<CODE>default-hash-function</CODE> is the hash function used in the tables
+ returned by <CODE>make-table</CODE>, and <CODE>string-hash</CODE> it the one used
+ by <CODE>make-string-table</CODE>.
+<HR >
+</BODY></HTML>
diff --git a/doc/install.txt b/doc/install.txt
new file mode 100644
index 0000000..7ffcada
--- /dev/null
+++ b/doc/install.txt
@@ -0,0 +1,159 @@
+-*- Mode: Indented-text; -*-
+
+Here are some remarks to complement what's in the INSTALL file.
+
+-----
+
+When running "make", don't worry if the ".notify" target fails.  Its
+only purpose is to send an email message to
+scheme-48-notifications@martigny.ai.mit.edu, so that we can get a
+rough idea of how much Scheme 48 is being used and by whom.  We
+promise not to use your name or email address for any commercial
+purpose.  If you don't want us to know, just do "make -t .notify"
+first. 
+     
+-----
+
+Customizing the installation
+
+  1. If you don't believe in configure scripts, or don't have a
+     /bin/sh that can handle the configure script, you can make
+     sysdep.h and Makefile manually from sysdep.h.in and Makefile.in.
+     The technique is fairly obvious.  For Makefile, just give
+     reasonable values for all of the variables at the top that are
+     defined as "foo = @foo@", e.g. srcdir=., CC=cc, LIBS=-lm,
+     INSTALL=cp, etc.  For sysdep.h, read the comments.  If your OS is
+     Posix compliant, you should be able to copy sysdep.h.in to
+     sysdep.h unmodified and everything should work.
+
+  2. If you definitely won't be installing Scheme 48, you should set
+     libdir to the distribution directory (e.g. "make libdir=`pwd`").
+     This will make the ,open and ,load-package commands work for the
+     library packages defined in more-packages.scm.
+
+  3. If desired, customize the contents of the development environment
+     heap image by editing the definitions of USUAL-COMMANDS and/or
+     USUAL-FEATURES in more-packages.scm; see below.
+
+  4. If you're using a DEC MIPS, and want to use the foreign function
+     interface, specify LDFLAGS=-N (with e.g. "make LDFLAGS=-N").
+
+-----
+
+Customizing scheme48.image
+
+By default, the image consists of a core Scheme system (Revised^5
+Scheme plus a very minimal read-eval-print loop) together with a
+standard set of "options" (command processor, debugging commands,
+inspector, disassembler, generic arithmetic).  The set of options is
+controlled by the definitions of USUAL-COMMANDS and USUAL-FEATURES in
+more-packages.scm.  If you make the (open ...) clause empty, then
+"make scheme48.image" will create a Scheme system without any extras
+(such as error recovery), and the image will be smaller.  The files
+are listed in approximate order of decreasing desirability; you'll
+probably want at least these:
+
+    package-commands, build
+       - necessary for the scheme48.image script to work
+    debuginfo, disclosers
+       - necessary if you want error messages to be at all helpful
+    debugging
+       - defines important debugging commands such as ,preview and ,trace
+
+After editing the definition of usual-features, simply
+
+        make scheme48.image
+
+to rebuild the image.
+
+-----
+
+Deeper changes to the system -- for example, edits to most of the
+files in the rts/ directory -- will require using the static linker to
+make a new initial.image.  After you have a working scheme48.image
+(perhaps a previous version of Scheme 48), you can create a linker
+image with
+
+        make linker
+
+after which you can say
+
+        make image
+
+to get the linker to build a new initial.image and initial.debug.
+scheme48.image will then be built from those.
+
+You might think that "make scheme48.image" ought to do this, but the
+circular dependencies
+
+  scheme48.image on initial.image
+  initial.image on link/linker.image
+  link/linker.image on scheme48.image
+
+needs to be broken somewhere, or else make will (justifiably) barf.  I
+chose to break the cycle by making scheme48.image not depend on
+initial.image, since this is most robust for installation purposes.
+
+-----
+
+Editor support
+
+We recommend interacting with the Scheme 48 command processor using the
+emacs/scheme interface written by Olin Shivers at CMU.  Copies of the
+relevant .el files, together with a "cmuscheme48.el", are in the
+emacs/ subdirectory of the release.  Usage information is in
+doc/user-guide.txt.
+
+You will probably want to byte-compile the .el files to get .elc
+files.  Use M-x byte-compile-file to do this.
+
+-----
+
+Performance
+
+If you don't have a C compiler that optimizes as well as gcc does,
+then performance may suffer.  Take a look at the automatically
+generated code in scheme48vm.c to find out why.  With a good register
+allocator, all those variables (including some of the virtual
+machine's virtual registers) get allocated to hardware registers, and
+it really flies.  Without one, performance can be pretty bad.
+
+The configure script automatically sets the Makefile variable CFLAGS
+to -O2 -g if gcc is available, or to -O if it isn't.  This can be
+overriden by specifying a different CFLAGS, e.g. "make CFLAGS=-g" for
+no optimization.
+
+Even if you do have a good compiler, you should be able to improve
+overall performance even more, maybe about 6-10%, by removing the
+range check from the interpreter's instruction dispatch.  To do this,
+use the -S flag to get assembly code for scheme48vm.c, then find the
+instructions in scheme48vm.s corresponding to the big dispatch in
+restart():
+
+ L19173: {
+  code_pointer_83X = arg1K0;
+  switch ((*((unsigned char *) code_pointer_83X))) {
+    ... }
+
+There will be one or two comparison instructions to see whether the
+opcode is in range; just remove them.  For the 68000 I use a "sed"
+ script
+
+    /cmpl #137,d0/ N
+    /cmpl #137,d0\n     jhi L/ d
+
+but of course the constant will probably have to change when a new
+release comes along.
+
+See the user's guide for information on the ,bench command, which
+makes programs run faster.
+
+-----
+
+filenames.make is "include"d by the Makefile, but is automatically
+generated from the module dependencies laid out in the various
+configuration files (*-packages.scm).  If you edit any of these .scm
+files, you may want to do a "make filenames.make" before you do any
+further "make"s in order to update the depedencies.  This step isn't
+necessary if you're using Gnu make, because Gnu make will make
+included files automatically.
diff --git a/doc/io.txt b/doc/io.txt
new file mode 100644
index 0000000..239e1d2
--- /dev/null
+++ b/doc/io.txt
@@ -0,0 +1,201 @@
+
+There are two types of I/O objects in Scheme 48, channels and ports.
+Channels are the raw, unbuffered ports of the operating system.  The
+only I/O operations the VM supports for channels are block reads and
+writes.  Ports are the actual Scheme ports and are implemented in Scheme,
+with some support from the VM for READ-CHAR, PEEK-CHAR, and WRITE-CHAR
+for efficiency.  The run-time system provides ports that are buffered
+versions of channels.  Other sorts of ports are in big/more-port.scm.
+
+Source files:
+
+  rts/port.scm            port operations and port handlers
+  rts/current-port.scm    current-input-port, etc.
+  rts/channel.scm         blocking on channels and handling i/o interrupts
+  rts/channel-port.scm    ports that read and write to channels
+  rts/low.scm             CHANNEL-READ and CHANNEL-WRITE
+  big/more-port.scm       additional kinds of ports
+  vm/arch.scm             fields of ports and channels
+  vm/prim-io.scm          VM i/o opcodes
+  vm/vmio.scm             implementation of channels
+  
+----------------------------------------------------------------
+
+CHANNELS
+
+The VM instructions that deal with channels are:
+
+ (OPEN-CHANNEL <spec> <mode>) -> channel
+   <mode> is a from the enumeration OPEN-CHANNEL-OPTION in arch.scm.
+   <spec> is either a filename (as a string) or an OS port (as a one-word
+   code-vector), depending on the mode.
+
+ (CLOSE-CHANNEL <channel>)    -> unspecific
+
+ (CHANNEL-MAYBE-READ <string-or-code-vector> <start-index> <count> <wait?>
+                     <channel>)
+                              -> number of bytes read or the eof-object
+ (CHANNEL-MAYBE-WRITE <string-or-code-vector> <start-index> <count> <channel>)
+                              -> number of bytes written
+   These read or write up to the specified number of characters or bytes
+   from or to the string or code-vector, with the first character or byte
+   going at <start-index>.
+
+ (CHANNEL-ABORT <channel>)    -> number of bytes read or written or
+                                 the eof-object
+   This aborts any pending read or write operation on the channel.  The return
+   value reflects any partial completion.
+
+CHANNEL-MAYBE-READ and CHANNEL-MAYBE-WRITE do not block.  If the read or
+write cannot be completed immediately a PENDING-CHANNEL-I/O exception is
+raised.  It is then up to the run-time system to either wait or run some
+other thread.  The VM raises an I/O-COMPLETION interrupt whenever an i/o
+operation completes.
+
+Because CHANNEL-MAYBE-READ and CHANNEL-MAYBE-WRITE are awkward to use,
+the RTS defines somewhat simpler versions:
+
+ (CHANNEL-READ <buffer> <start> <needed> <channel>)
+                              -> number of bytes read or the eof-object
+ (CHANNEL-WRITE <buffer> <start> <count> <channel>)
+                              -> unspecified
+   <Buffer> is either a string or code vector and <start> is the index of the
+   first character read or written. <Needed> is one of:
+     N > 0 : the call returns when this many characters has been read or
+        an EOF is reached.
+     'IMMEDIATE : the call reads as many characters as are available and
+        returns immediately.
+     'ANY : the call returns as soon as at least one character has been read
+        or an EOF is reached.
+   <Count> is the number of characters to be written.  CHANNEL-READ will read
+   the requested number of characters unless an EOF is reached.  CHANNEL-WRITE
+   will write the requested number of characters.
+
+----------------------------------------------------------------
+
+PORTS
+
+Ports are actual Scheme port and are (usually) buffered.  They are fully
+exposed to the run-time system.  The VM instructions on ports could be
+implemented in Scheme; they are in the VM for efficiency.  Buffers are
+code-vectors (this is a micro-hack; strings have a slightly higher overhead
+because of the null terminating byte for C compatibility) (code-vectors are
+just vectors of bytes).
+
+The fields of a port are:
+ 
+ PORT-STATUS: a bit set represented as a fixnum.
+  Indices into this bit set are from the PORT-STATUS-OPTIONS
+  enumeration in arch.scm.  The current bits are: input, output,
+  open-for-input, open-for-output (the last two are for things like
+  sockets, on which you need to block but which do not support
+  normal reading or writing).
+
+ PORT-HANDLER: a record containing three procedures.  These handle
+  printing the port, closing the port, and filling (for input ports)
+  or emptying (for output ports) buffers.
+
+ PORT-DATA: ?
+  Whatever stuff the handler needs.
+
+ PORT-LOCKED?, PORT-LOCK: used by the system to guarentee the atomicity
+  of i/o operations.
+
+ PORT-BUFFER: a code-vector.  The input or output buffer of the port.
+
+ PORT-INDEX: a fixnum.  The index of the next byte to read or written.
+
+ PORT-LIMIT: a fixnum.  One past the end of the valid/available buffer space.
+
+ PORT-PENDING-EOF?: true if the next read to this port should return EOF.
+
+Additional operations on ports:
+
+ (READ-BLOCK string-or-code-vector start count input-port)
+    Read COUNT bytes into STRING-OR-CODE-VECTOR starting at index START.
+    Returns the number of bytes read.  Only an end-of-file will prevent
+    the requested number of bytes from being read.
+ 
+ (WRITE-STRING string output-port)
+    Write the characters in the string to the port.
+
+ (WRITE-BLOCK string-or-code-vector start count output-port)
+    The output counterpart to READ-BLOCK.  This always writes out the
+    requested number of bytes.  Its return value is unspecified.
+
+ (FORCE_OUTPUT output-port)
+    Causes any buffered characters to be written out.
+    
+ (CURRENT-ERROR-PORT)
+    The current error port, analogous to Scheme's CURRENT-INPUT-PORT
+    and CURRENT-OUTPUT-PORT.
+
+The system maintains a list of output ports whose buffers should be
+periodically flushed.  The default output port and ports made by
+OPEN-OUTPUT-FILE are on this list.  (PERIODICALLY-FORCE-OUTPUT! <output-port>)
+may be used to add others.
+
+----------------------------------------------------------------
+
+PORT HANDLERS
+
+Every port has a handler with three procedures.  The first two are used
+for printing and closing ports and have the same type for all ports:
+ 
+ (DISCLOSE port-data) -> disclose list
+ (CLOSE port-data) -> unspecific
+
+For CLOSE, The system takes care of modifying the port's status.
+
+The third procedure is used to fill and empty buffers.  Its arguments
+and return values depend on the kind of port:
+
+ Buffered output ports:
+  (BUFFER-PROC port-data buffer start-index byte-count) -> unspecific
+    BYTE-COUNT bytes should be copied from the buffer beginning at
+    START-INDEX.  The buffer may be either a string or a code-vector.
+
+ Unbuffered output ports:
+  (BUFFER-PROC port-data char) -> unspecific
+    Write out the given character.  The system uses this for the default
+    error port.
+
+ Input ports:
+  (BUFFER-PROC data buffer start-index needed-bytes)
+     -> EOF or number of bytes read (before an EOF)
+    Bytes should be copied into the buffer starting at START-INDEX.  The
+    buffer may be either a string or a code-vector.  NEEDED-BYTES is one of:
+
+      'IMMEDIATE
+        The call should return immediately after transfering whatever number
+        of bytes are currently available, possibly none (this is used for
+	CHAR-READY?). The maximum number of characters is determined by the
+	length of BUFFER.
+
+      'ANY
+        The call should wait until at least one byte is available or an EOF
+        occurs (used for READ-CHAR and PEEK-CHAR).  The maximum number of
+	characters is determined by the length of BUFFER.
+
+      N > 0
+        The call should wait until N bytes have been copied into the buffer
+        or an EOF occurs.  If the return value is less than NEEDED-BYTES the
+        port code inserts an EOF after the last byte.
+
+----------------------------------------------------------------
+
+Ports and the Virtual Machine
+
+Ports could be implemented entirely in Scheme, with no support from
+the VM.  For efficiency reasons VM instructions are supplied for
+three port operations:
+
+  (READ-CHAR <port>)
+  (PEEK-CHAR <port>)
+  (WRITE-CHAR <char> <port>)
+
+For each of these, if there is sufficient data or space in the
+appropriate buffer the VM performs the operation.  Otherwise a
+buffer-full/empty exception is raised and the exception handler
+uses the buffer procedure from the port's handler to fill or
+empty the buffer.
diff --git a/doc/meeting.ps b/doc/meeting.ps
new file mode 100644
index 0000000..3fcb07d
--- /dev/null
+++ b/doc/meeting.ps
@@ -0,0 +1,1090 @@
+%!PS-Adobe-2.0
+%%Creator: dvips 5.521 Copyright 1986, 1993 Radical Eye Software
+%%CreationDate: Sat Jan 15 16:05:04 1994
+%%Pages: 8
+%%PageOrder: Ascend
+%%BoundingBox: 0 0 612 792
+%%EndComments
+%DVIPSCommandLine: dvips -f
+%DVIPSSource:  TeX output 1994.01.15:1605
+%%BeginProcSet: tex.pro
+/TeXDict 250 dict def TeXDict begin /N{def}def /B{bind def}N /S{exch}N
+/X{S N}B /TR{translate}N /isls false N /vsize 11 72 mul N /hsize 8.5 72
+mul N /landplus90{false}def /@rigin{isls{[0 landplus90{1 -1}{-1 1}
+ifelse 0 0 0]concat}if 72 Resolution div 72 VResolution div neg scale
+isls{landplus90{VResolution 72 div vsize mul 0 exch}{Resolution -72 div
+hsize mul 0}ifelse TR}if Resolution VResolution vsize -72 div 1 add mul
+TR matrix currentmatrix dup dup 4 get round 4 exch put dup dup 5 get
+round 5 exch put setmatrix}N /@landscape{/isls true N}B /@manualfeed{
+statusdict /manualfeed true put}B /@copies{/#copies X}B /FMat[1 0 0 -1 0
+0]N /FBB[0 0 0 0]N /nn 0 N /IE 0 N /ctr 0 N /df-tail{/nn 8 dict N nn
+begin /FontType 3 N /FontMatrix fntrx N /FontBBox FBB N string /base X
+array /BitMaps X /BuildChar{CharBuilder}N /Encoding IE N end dup{/foo
+setfont}2 array copy cvx N load 0 nn put /ctr 0 N[}B /df{/sf 1 N /fntrx
+FMat N df-tail}B /dfs{div /sf X /fntrx[sf 0 0 sf neg 0 0]N df-tail}B /E{
+pop nn dup definefont setfont}B /ch-width{ch-data dup length 5 sub get}
+B /ch-height{ch-data dup length 4 sub get}B /ch-xoff{128 ch-data dup
+length 3 sub get sub}B /ch-yoff{ch-data dup length 2 sub get 127 sub}B
+/ch-dx{ch-data dup length 1 sub get}B /ch-image{ch-data dup type
+/stringtype ne{ctr get /ctr ctr 1 add N}if}B /id 0 N /rw 0 N /rc 0 N /gp
+0 N /cp 0 N /G 0 N /sf 0 N /CharBuilder{save 3 1 roll S dup /base get 2
+index get S /BitMaps get S get /ch-data X pop /ctr 0 N ch-dx 0 ch-xoff
+ch-yoff ch-height sub ch-xoff ch-width add ch-yoff setcachedevice
+ch-width ch-height true[1 0 0 -1 -.1 ch-xoff sub ch-yoff .1 add]{
+ch-image}imagemask restore}B /D{/cc X dup type /stringtype ne{]}if nn
+/base get cc ctr put nn /BitMaps get S ctr S sf 1 ne{dup dup length 1
+sub dup 2 index S get sf div put}if put /ctr ctr 1 add N}B /I{cc 1 add D
+}B /bop{userdict /bop-hook known{bop-hook}if /SI save N @rigin 0 0
+moveto /V matrix currentmatrix dup 1 get dup mul exch 0 get dup mul add
+.99 lt{/QV}{/RV}ifelse load def pop pop}N /eop{SI restore showpage
+userdict /eop-hook known{eop-hook}if}N /@start{userdict /start-hook
+known{start-hook}if pop /VResolution X /Resolution X 1000 div /DVImag X
+/IE 256 array N 0 1 255{IE S 1 string dup 0 3 index put cvn put}for
+65781.76 div /vsize X 65781.76 div /hsize X}N /p{show}N /RMat[1 0 0 -1 0
+0]N /BDot 260 string N /rulex 0 N /ruley 0 N /v{/ruley X /rulex X V}B /V
+{}B /RV statusdict begin /product where{pop product dup length 7 ge{0 7
+getinterval dup(Display)eq exch 0 4 getinterval(NeXT)eq or}{pop false}
+ifelse}{false}ifelse end{{gsave TR -.1 -.1 TR 1 1 scale rulex ruley
+false RMat{BDot}imagemask grestore}}{{gsave TR -.1 -.1 TR rulex ruley
+scale 1 1 false RMat{BDot}imagemask grestore}}ifelse B /QV{gsave
+transform round exch round exch itransform moveto rulex 0 rlineto 0
+ruley neg rlineto rulex neg 0 rlineto fill grestore}B /a{moveto}B /delta
+0 N /tail{dup /delta X 0 rmoveto}B /M{S p delta add tail}B /b{S p tail}
+B /c{-4 M}B /d{-3 M}B /e{-2 M}B /f{-1 M}B /g{0 M}B /h{1 M}B /i{2 M}B /j{
+3 M}B /k{4 M}B /w{0 rmoveto}B /l{p -4 w}B /m{p -3 w}B /n{p -2 w}B /o{p
+-1 w}B /q{p 1 w}B /r{p 2 w}B /s{p 3 w}B /t{p 4 w}B /x{0 S rmoveto}B /y{
+3 2 roll p a}B /bos{/SS save N}B /eos{SS restore}B end
+%%EndProcSet
+TeXDict begin 40258431 52099146 1000 300 300 () @start
+/Fa 1 111 df<383C0044C6004702004602008E06000C06000C06000C0C00180C00180C
+40181840181880300880300F00120E7F8D15>110 D E /Fb 3 111
+df<70F8F8F87005057C840D>58 D<70F8FCFC74040404080810102040060E7C840D>I<1E
+07802318C023A06043C0704380704380708700E00700E00700E00700E00E01C00E01C00E
+01C00E03821C03841C07041C07081C03083803101801E017147E931B>110
+D E /Fc 28 122 df<00003FE00000E01000018038000380780003007800070030000700
+000007000000070000000E0000000E0000000E000000FFFFE0000E00E0001C01C0001C01
+C0001C01C0001C01C0001C03800038038000380380003803800038070000380700007007
+000070071000700E2000700E2000700E2000E00E2000E0064000E0038000E0000000C000
+0001C0000001C000003180000079800000F3000000620000003C0000001D29829F1A>12
+D<7FF0FFE07FE00C037D8A10>45 D<01FFF800001F0000001E0000001E0000001E000000
+3C0000003C0000003C0000003C00000078000000780000007800000078000000F0000000
+F0000000F0000000F0000001E0000001E0000001E0000001E0008003C0010003C0010003
+C0030003C00200078006000780060007800C0007801C000F007800FFFFF800191F7D9E1D
+>76 D<01FFFF80001E00E0001E0070001E0038001E003C003C003C003C003C003C003C00
+3C003C0078007800780078007800F0007800E000F003C000F00F0000FFFC0000F0000001
+E0000001E0000001E0000001E0000003C0000003C0000003C0000003C000000780000007
+80000007800000078000000F800000FFF000001E1F7D9E1F>80 D<FFF007FC0F8000E00F
+0000C00F0000800F0001000F0001000F0002000F0004000F0004000F8008000780080007
+8010000780200007802000078040000780400007808000078100000781000007C2000003
+C2000003C4000003C8000003C8000003D0000003D0000003E0000003C0000003C0000003
+80000001800000010000001E20779E22>86 D<00F1800389C00707800E03801C03803C03
+80380700780700780700780700F00E00F00E00F00E00F00E20F01C40F01C40703C40705C
+40308C800F070013147C9317>97 D<07803F8007000700070007000E000E000E000E001C
+001C001CF01D0C3A0E3C0E380F380F700F700F700F700FE01EE01EE01EE01CE03CE03860
+7060E031C01F0010207B9F15>I<007E0001C1000300800E07801E07801C07003C020078
+0000780000780000F00000F00000F00000F00000F0000070010070020030040018380007
+C00011147C9315>I<0000780003F80000700000700000700000700000E00000E00000E0
+0000E00001C00001C000F1C00389C00707800E03801C03803C0380380700780700780700
+780700F00E00F00E00F00E00F00E20F01C40F01C40703C40705C40308C800F070015207C
+9F17>I<007C01C207010E011C013C013802780C7BF07C00F000F000F000F00070007001
+70023804183807C010147C9315>I<00007800019C00033C00033C000718000700000700
+000E00000E00000E00000E00000E0001FFE0001C00001C00001C00001C00003800003800
+00380000380000380000700000700000700000700000700000700000E00000E00000E000
+00E00000C00001C00001C0000180003180007B0000F300006600003C00001629829F0E>
+I<003C6000E27001C1E00380E00700E00F00E00E01C01E01C01E01C01E01C03C03803C03
+803C03803C03803C07003C07001C0F001C17000C2E0003CE00000E00000E00001C00001C
+00301C00783800F0700060E0003F8000141D7E9315>I<01E0000FE00001C00001C00001
+C00001C000038000038000038000038000070000070000071E000763000E81800F01C00E
+01C00E01C01C03801C03801C03801C0380380700380700380700380E10700E20700C2070
+1C20700C40E00CC060070014207D9F17>I<00C001E001E001C000000000000000000000
+000000000E003300230043804300470087000E000E000E001C001C001C00384038803080
+7080310033001C000B1F7C9E0E>I<0001800003C00003C0000380000000000000000000
+000000000000000000000000003C00004600008700008700010700010700020E00000E00
+000E00000E00001C00001C00001C00001C00003800003800003800003800007000007000
+00700000700000E00000E00030E00079C000F180006300003C00001228829E0E>I<01E0
+000FE00001C00001C00001C00001C0000380000380000380000380000700000700000703
+C00704200E08E00E11E00E21E00E40C01C80001D00001E00001FC00038E0003870003870
+00383840707080707080707080703100E03100601E0013207D9F15>I<03C01FC0038003
+800380038007000700070007000E000E000E000E001C001C001C001C0038003800380038
+007000700070007100E200E200E200E200640038000A207C9F0C>I<1C0F80F0002630C3
+18004740640C004780680E004700700E004700700E008E00E01C000E00E01C000E00E01C
+000E00E01C001C01C038001C01C038001C01C038001C01C0708038038071003803806100
+380380E10038038062007007006600300300380021147C9325>I<1C0F802630C0474060
+4780604700704700708E00E00E00E00E00E00E00E01C01C01C01C01C01C01C0384380388
+3803083807083803107003303001C016147C931A>I<007C0001C3000301800E01C01E01
+C01C01E03C01E07801E07801E07801E0F003C0F003C0F003C0F00780F00700700F00700E
+0030180018700007C00013147C9317>I<01C1E002621804741C04781C04701E04701E08
+E01E00E01E00E01E00E01E01C03C01C03C01C03C01C0380380780380700380E003C1C007
+2380071E000700000700000E00000E00000E00000E00001C00001C0000FFC000171D8093
+17>I<1C1E002661004783804787804707804703008E00000E00000E00000E00001C0000
+1C00001C00001C000038000038000038000038000070000030000011147C9313>114
+D<00FC030206010C030C070C060C000F800FF007F803FC003E000E700EF00CF00CE00840
+1020601F8010147D9313>I<018001C0038003800380038007000700FFF007000E000E00
+0E000E001C001C001C001C003800380038003820704070407080708031001E000C1C7C9B
+0F>I<0E00C03300E02301C04381C04301C04701C08703800E03800E03800E03801C0700
+1C07001C07001C07101C0E20180E20180E201C1E200C264007C38014147C9318>I<0E03
+803307802307C04383C04301C04700C08700800E00800E00800E00801C01001C01001C01
+001C02001C02001C04001C04001C08000E300003C00012147C9315>I<0383800CC44010
+68E01071E02071E02070C040E00000E00000E00000E00001C00001C00001C00001C04063
+8080F38080F38100E5810084C60078780013147D9315>120 D<0E00C03300E02301C043
+81C04301C04701C08703800E03800E03800E03801C07001C07001C07001C07001C0E0018
+0E00180E001C1E000C3C0007DC00001C00001C00003800F03800F07000E06000C0C00043
+80003E0000131D7C9316>I E /Fd 10 117 df<03FF8000700000700000700000E00000
+E00000E00000E00001C00001C00001C00001C00003800003800003800003800007000007
+00100700100700200E00200E00600E00400E00C01C0380FFFF80141A7D9918>76
+D<03FFF800701C00700600700700E00700E00700E00700E00701C00E01C00E01C01C01C0
+3803807003FF800380000380000700000700000700000700000E00000E00000E00000E00
+001C0000FFC000181A7D991A>80 D<01E006181C08380870087010FFE0E000E000E000E0
+00E0086010602030C01F000D107C8F12>101 D<030706000000000000384C4E8E9C9C1C
+3838707272E2E4643808197C980C>105 D<307C005986009E07009E07009C07009C0700
+380E00380E00380E00381C00701C80701C80703880703900E01900600E0011107C8F16>
+110 D<01F006180C0C180E300E700E600EE00EE00EE00CE01CE018E030606030C01F000F
+107C8F14>I<030F000590C009E0C009C06009C06009C0600380E00380E00380E00380E0
+0701C00701800703800703000E8E000E78000E00000E00001C00001C00001C00001C0000
+FF00001317808F14>I<30F059189E389C189C009C003800380038003800700070007000
+7000E00060000D107C8F10>114 D<03E004300830187018601C001F801FC00FE000E000
+60E060E06080C041803E000C107D8F10>I<06000E000E000E000E001C001C00FFC01C00
+38003800380038007000700070007000E100E100E100E200640038000A177C960D>I
+E /Fe 24 124 df<00800100020004000C00080018003000300030006000600060006000
+E000E000E000E000E000E000E000E000E000E00060006000600060003000300030001800
+08000C00040002000100008009267D9B0F>40 D<8000400020001000180008000C000600
+060006000300030003000300038003800380038003800380038003800380038003000300
+030003000600060006000C0008001800100020004000800009267E9B0F>I<60F0F07010
+101020204080040B7D830B>44 D<60F0F06004047D830B>46 D<03000700FF0007000700
+070007000700070007000700070007000700070007000700070007000700070007000700
+FFF00C187D9713>49 D<0F80106020304038803CC01CE01C401C003C0038003800700060
+00C001800100020004040804100430083FF87FF8FFF80E187E9713>I<00300030007000
+F000F001700370027004700C7008701070307020704070C070FFFF007000700070007000
+70007007FF10187F9713>52 D<07801860303070306018E018E018E01CE01CE01C601C60
+3C303C185C0F9C001C00180018003870307060604021801F000E187E9713>57
+D<FFFF000E01C00E00E00E00300E00380E001C0E001C0E000E0E000E0E000F0E000F0E00
+0F0E000F0E000F0E000F0E000F0E000F0E000E0E000E0E001E0E001C0E00380E00380E00
+700E01C0FFFF00181A7E991D>68 D<007F000001C1C000070070000E0038001C001C003C
+001E0038000E0078000F0070000700F0000780F0000780F0000780F0000780F0000780F0
+000780F0000780F000078078000F0078000F0038000E003C001E001C001C000E00380007
+00700001C1C000007F0000191A7E991E>79 D<7FFFFF00701C0700401C0100401C0100C0
+1C0180801C0080801C0080801C0080001C0000001C0000001C0000001C0000001C000000
+1C0000001C0000001C0000001C0000001C0000001C0000001C0000001C0000001C000000
+1C0000001C0000001C000003FFE000191A7F991C>84 D<FF801FC01E000F001C0006000E
+0004000E000400070008000700080007000800038010000380100003C0300001C0200001
+C0200000E0400000E0400000E04000007080000070800000390000003900000039000000
+1E0000001E0000001E0000000C0000000C00001A1A7F991D>86 D<3F8070C070E0207000
+70007007F01C7030707070E070E071E071E0F171FB1E3C10107E8F13>97
+D<FC00001C00001C00001C00001C00001C00001C00001C00001C00001C00001CF8001F0E
+001E07001C03801C01801C01C01C01C01C01C01C01C01C01C01C01C01C03801C03001E07
+001B0C0010F000121A7F9915>I<07F80C1C381C30087000E000E000E000E000E000E000
+7000300438080C1807E00E107F8F11>I<07C01C3030187018600CE00CFFFCE000E000E0
+00E0006000300438080C1807E00E107F8F11>101 D<18003C003C001800000000000000
+000000000000FC001C001C001C001C001C001C001C001C001C001C001C001C001C001C00
+FF80091A80990A>105 D<FC7C1F001D8E63801E0781C01E0781C01C0701C01C0701C01C
+0701C01C0701C01C0701C01C0701C01C0701C01C0701C01C0701C01C0701C01C0701C0FF
+9FE7F81D107F8F20>109 D<FCF8001D0C001E0E001E0E001C0E001C0E001C0E001C0E00
+1C0E001C0E001C0E001C0E001C0E001C0E001C0E00FF9FC012107F8F15>I<07E01C3830
+0C700E6006E007E007E007E007E007E0076006700E381C1C3807E010107F8F13>I<FCF8
+001F0E001E07001C03801C03801C01C01C01C01C01C01C01C01C01C01C01C01C03801C03
+001E07001F0C001CF0001C00001C00001C00001C00001C00001C0000FF800012177F8F15
+>I<FCE01D701E701E201C001C001C001C001C001C001C001C001C001C001C00FFC00C10
+7F8F0F>114 D<0400040004000C000C001C003C00FFC01C001C001C001C001C001C001C
+001C001C201C201C201C201C200E4003800B177F960F>116 D<FFFFC01201808913>123
+D E /Ff 1 50 df<0C003C00CC000C000C000C000C000C000C000C000C000C000C000C00
+0C00FF8009107E8F0F>49 D E /Fg 30 121 df<0000600000E00000E00001C00001C000
+0380000380000380000700000700000700000E00000E00001C00001C00001C0000380000
+380000380000700000700000E00000E00000E00001C00001C00003800003800003800007
+00000700000700000E00000E00001C00001C00001C000038000038000038000070000070
+0000E00000E00000C00000132D7DA11A>47 D<387CFEFEFE7C38000000000000387CFEFE
+FE7C3807147C930F>58 D<0000E000000000E000000001F000000001F000000001F00000
+0003F800000003F800000006FC00000006FC0000000EFE0000000C7E0000000C7E000000
+183F000000183F000000303F800000301F800000701FC00000600FC00000600FC00000C0
+07E00000FFFFE00001FFFFF000018003F000018003F000030001F800030001F800060001
+FC00060000FC000E0000FE00FFE00FFFE0FFE00FFFE0231F7E9E28>65
+D<0007FC02003FFF0E00FE03DE03F000FE07E0003E0FC0001E1F80001E3F00000E3F0000
+0E7F0000067E0000067E000006FE000000FE000000FE000000FE000000FE000000FE0000
+00FE0000007E0000007E0000067F0000063F0000063F00000C1F80000C0FC0001807E000
+3803F0007000FE01C0003FFF800007FC001F1F7D9E26>67 D<FFFFFFE0FFFFFFE007E007
+E007E001E007E000E007E0006007E0007007E0003007E0003007E0603007E0603007E060
+0007E0E00007E1E00007FFE00007FFE00007E1E00007E0E00007E0600007E0600C07E060
+0C07E0000C07E0001807E0001807E0001807E0003807E0007807E000F807E003F0FFFFFF
+F0FFFFFFF01E1F7E9E22>69 D<FFFFFFFF07E007E007E007E007E007E007E007E007E007
+E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007E0FF
+FFFFFF101F7E9E14>73 D<FFE000003FF8FFF000007FF807F000007F0006F80000DF0006
+F80000DF0006F80000DF00067C00019F00067C00019F00063E00031F00063E00031F0006
+1F00061F00061F00061F00060F800C1F00060F800C1F000607C0181F000607C0181F0006
+07C0181F000603E0301F000603E0301F000601F0601F000601F0601F000600F8C01F0006
+00F8C01F0006007D801F0006007D801F0006003F001F0006003F001F0006003F001F0006
+001E001F00FFF01E03FFF8FFF00C03FFF82D1F7E9E32>77 D<03FC080FFF381E03F83800
+F8700078700038F00038F00018F00018F80000FC00007FC0007FFE003FFF801FFFE00FFF
+F007FFF000FFF80007F80000FC00007C00003CC0003CC0003CC0003CE00038E00078F800
+70FE01E0E7FFC081FF00161F7D9E1D>83 D<FFFF01FFE0FFFF01FFE007E0000C0007E000
+0C0007E0000C0007E0000C0007E0000C0007E0000C0007E0000C0007E0000C0007E0000C
+0007E0000C0007E0000C0007E0000C0007E0000C0007E0000C0007E0000C0007E0000C00
+07E0000C0007E0000C0007E0000C0007E0000C0007E0000C0007E0000C0003E000180001
+F000180001F000300000F8006000007E03C000001FFF80000003FC0000231F7E9E28>85
+D<07FC001FFF003F0F803F07C03F03E03F03E00C03E00003E0007FE007FBE01F03E03C03
+E07C03E0F803E0F803E0F803E0FC05E07E0DE03FF8FE0FE07E17147F9319>97
+D<01FE0007FF801F0FC03E0FC03E0FC07C0FC07C0300FC0000FC0000FC0000FC0000FC00
+00FC00007C00007E00003E00603F00C01F81C007FF0001FC0013147E9317>99
+D<0007F80007F80000F80000F80000F80000F80000F80000F80000F80000F80000F80000
+F801F8F80FFEF81F83F83E01F87E00F87C00F87C00F8FC00F8FC00F8FC00F8FC00F8FC00
+F8FC00F87C00F87C00F87E00F83E01F81F07F80FFEFF03F8FF18207E9F1D>I<01FE0007
+FF800F83C01E01E03E00F07C00F07C00F8FC00F8FFFFF8FFFFF8FC0000FC0000FC00007C
+00007C00003E00181E00180F807007FFE000FF8015147F9318>I<001F8000FFC001F3E0
+03E7E003C7E007C7E007C3C007C00007C00007C00007C00007C000FFFC00FFFC0007C000
+07C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C00007C000
+07C00007C00007C0003FFC003FFC0013207F9F10>I<01FC3C07FFFE0F079E1E03DE3E03
+E03E03E03E03E03E03E03E03E01E03C00F07800FFF0009FC001800001800001C00001FFF
+800FFFF007FFF81FFFFC3C007C70003EF0001EF0001EF0001E78003C78003C3F01F80FFF
+E001FF00171E7F931A>I<FF0000FF00001F00001F00001F00001F00001F00001F00001F
+00001F00001F00001F00001F0FC01F3FE01F61F01FC0F81F80F81F00F81F00F81F00F81F
+00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F8FFE3FFFFE3FF18
+207D9F1D>I<1C003E007F007F007F003E001C00000000000000000000000000FF00FF00
+1F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F00FFE0FFE0
+0B217EA00E>I<FF0000FF00001F00001F00001F00001F00001F00001F00001F00001F00
+001F00001F00001F01FE1F01FE1F00F01F00C01F03801F07001F0C001F18001F7C001FFC
+001F9E001F0F001E0F801E07C01E03C01E01E01E01F01E00F8FFC3FFFFC3FF18207E9F1C
+>107 D<FF00FF001F001F001F001F001F001F001F001F001F001F001F001F001F001F00
+1F001F001F001F001F001F001F001F001F001F001F001F001F001F00FFE0FFE00B207E9F
+0E>I<FE0FE03F80FE1FF07FC01E70F9C3E01E407D01F01E807E01F01F807E01F01F007C
+01F01F007C01F01F007C01F01F007C01F01F007C01F01F007C01F01F007C01F01F007C01
+F01F007C01F01F007C01F01F007C01F01F007C01F0FFE3FF8FFEFFE3FF8FFE27147D932C
+>I<FE0FC0FE3FE01E61F01EC0F81E80F81F00F81F00F81F00F81F00F81F00F81F00F81F
+00F81F00F81F00F81F00F81F00F81F00F81F00F8FFE3FFFFE3FF18147D931D>I<01FF00
+07FFC01F83F03E00F83E00F87C007C7C007CFC007EFC007EFC007EFC007EFC007EFC007E
+7C007C7C007C3E00F83E00F81F83F007FFC001FF0017147F931A>I<FF1FC0FF7FF01FE1
+F81F80FC1F007E1F007E1F003E1F003F1F003F1F003F1F003F1F003F1F003F1F003E1F00
+7E1F007C1F80FC1FC1F81F7FE01F1F801F00001F00001F00001F00001F00001F00001F00
+00FFE000FFE000181D7E931D>I<FE3E00FE7F801ECFC01E8FC01E8FC01F8FC01F03001F
+00001F00001F00001F00001F00001F00001F00001F00001F00001F00001F0000FFF000FF
+F00012147E9316>114 D<0FE63FFE701E600EE006E006F800FFC07FF83FFC1FFE03FE00
+1FC007C007E007F006F81EFFFCC7F010147E9315>I<0180018001800380038003800780
+0F803F80FFFCFFFC0F800F800F800F800F800F800F800F800F800F800F860F860F860F86
+0F8607CC03F801F00F1D7F9C14>I<FF07F8FF07F81F00F81F00F81F00F81F00F81F00F8
+1F00F81F00F81F00F81F00F81F00F81F00F81F00F81F00F81F01F81F01F80F06F807FCFF
+03F8FF18147D931D>I<FFE07F80FFE07F801F001C000F8018000F80180007C0300007C0
+300003E0600003E0600001F0C00001F0C00001F9C00000F9800000FF8000007F0000007F
+0000003E0000003E0000001C0000001C000019147F931C>I<FFE7FE1FE0FFE7FE1FE01F
+00F003001F00F803000F80F806000F80F8060007C1BC0C0007C1BC0C0007C1BE0C0003E3
+1E180003E31E180001F60F300001F60F300001F60FB00000FC07E00000FC07E000007803
+C000007803C000007803C000003001800023147F9326>I<FFE1FF00FFE1FF000F807000
+07C0E00007E0C00003E1800001F3800000FF0000007E0000003E0000003F0000007F8000
+006F800000C7C0000183E0000381F0000701F8000E00FC00FF81FF80FF81FF8019147F93
+1C>I E /Fh 6 106 df<FFFFFFC0FFFFFFC01A027C8B23>0 D<01800180018001800180
+C183F18F399C0FF003C003C00FF0399CF18FC1830180018001800180018010147D9417>
+3 D<03C00FF01FF83FFC7FFE7FFEFFFFFFFFFFFFFFFFFFFFFFFF7FFE7FFE3FFC1FF80FF0
+03C010127D9317>15 D<0000000400000000020000000002000000000100000000008000
+000000400000000020FFFFFFFFFCFFFFFFFFFC0000000020000000004000000000800000
+00010000000002000000000200000000040026107D922D>33 D<004000C0018001800180
+0300030003000600060006000C000C00180018001800300030003000600060006000C000
+C0006000600060003000300030001800180018000C000C00060006000600030003000300
+01800180018000C000400A2E7CA112>104 D<C000C00060006000600030003000300018
+00180018000C000C0006000600060003000300030001800180018000C000C00180018001
+800300030003000600060006000C000C00180018001800300030003000600060006000C0
+00C0000A2E7DA112>I E /Fi 40 122 df<70F8F8F8F8F8F8F8F8F8F8F8F8F8F8F8F870
+000000000070F8F8F870051C779B18>33 D<030600078F00078F00078F00078F00078F00
+078F007FFFC0FFFFE0FFFFE07FFFC00F1E000F1E000F1E000F1E000F1E000F1E007FFFC0
+FFFFE0FFFFE07FFFC01E3C001E3C001E3C001E3C001E3C001E3C000C1800131C7E9B18>
+35 D<387C7C7E3E0E0E0E1C1C38F8F0C0070E789B18>39 D<007000F001E003C007800F
+001E001C00380038007000700070007000E000E000E000E000E000E000E000E000700070
+0070007000380038001C001E000F00078003C001F000F000700C24799F18>I<6000F000
+78003C001E000F000780038001C001C000E000E000E000E0007000700070007000700070
+0070007000E000E000E000E001C001C0038007800F001E003C007800F00060000C247C9F
+18>I<01C00001C00001C00001C000C1C180F1C780F9CF807FFF001FFC0007F00007F000
+1FFC007FFF00F9CF80F1C780C1C18001C00001C00001C00001C00011147D9718>I<0060
+0000F00000F00000F00000F00000F00000F00000F0007FFFC0FFFFE0FFFFE07FFFC000F0
+0000F00000F00000F00000F00000F00000F00000600013147E9718>I<7FFF00FFFF80FF
+FF807FFF0011047D8F18>45 D<3078FCFC78300606778518>I<03F0000FFE003FFF007C
+0F807003C0E001C0F000E0F000E06000E00000E00000E00001C00001C00003C000078000
+0F00001E00003C0000780000F00001E00007C0000F80001E00E03C00E07FFFE0FFFFE07F
+FFE0131C7E9B18>50 D<07F8001FFE003FFF007807807803C07801C03001C00001C00003
+C0000380000F0003FF0003FE0003FF000007800003C00001C00000E00000E00000E0F000
+E0F000E0F001C0F003C07C07803FFF001FFE0003F800131C7E9B18>I<1FFF803FFF803F
+FF803800003800003800003800003800003800003800003800003BF8003FFE003FFF003C
+07801803C00001C00000E00000E06000E0F000E0F000E0E001C07003C07C0F803FFF001F
+FC0003F000131C7E9B18>53 D<007E0001FF0007FF800F83C01E03C01C03C03801803800
+00700000700000E1F800E7FE00FFFF00FE0780F803C0F001C0F000E0E000E0F000E07000
+E07000E07000E03801C03C03C01E07800FFF0007FE0001F800131C7E9B18>I<600000F0
+0000FC00007E00003F00001FC00007E00003F00001FC00007E00003F00001F80001F8000
+3F00007E0001FC0003F00007E0001FC0003F00007E0000FC0000F0000060000011187D99
+18>62 D<0FF0003FFC007FFF00700F00F00380F00380600780000F00003E00007C0001F0
+0001E00003C00003C00003C00003C00003C0000380000000000000000000000000000000
+0003800007C00007C00007C000038000111C7D9B18>I<007C0001FE0007FF000F87801E
+03C03C1DC0387FC070FFE071E3E071C1E0E1C1E0E380E0E380E0E380E0E380E0E380E0E3
+80E0E1C1C071C1C071E3C070FF80387F003C1C001E00E00F83E007FFC001FF80007E0013
+1C7E9B18>I<1FE0003FF8007FFC00781E00300E0000070000070000FF0007FF001FFF00
+7F0700780700E00700E00700E00700F00F00781F003FFFF01FFBF007E1F014147D9318>
+97 D<7E0000FE00007E00000E00000E00000E00000E00000E00000E3E000EFF800FFFC0
+0FC1E00F80E00F00700E00700E00380E00380E00380E00380E00380E00380F00700F0070
+0F80E00FC1E00FFFC00EFF80063E00151C809B18>I<01FE0007FF001FFF803E07803803
+00700000700000E00000E00000E00000E00000E00000E000007000007001C03801C03E03
+C01FFF8007FF0001FC0012147D9318>I<001F80003F80001F8000038000038000038000
+038000038003E3800FFB801FFF803C1F80380F80700780700380E00380E00380E00380E0
+0380E00380E00380700780700780380F803C1F801FFFF00FFBF803E3F0151C7E9B18>I<
+01F00007FC001FFE003E0F00380780700380700380E001C0E001C0FFFFC0FFFFC0FFFFC0
+E000007000007001C03801C03E03C01FFF8007FF0001FC0012147D9318>I<001F80007F
+C000FFE000E1E001C0C001C00001C00001C0007FFFC0FFFFC0FFFFC001C00001C00001C0
+0001C00001C00001C00001C00001C00001C00001C00001C00001C00001C00001C0007FFF
+007FFF007FFF00131C7F9B18>I<01E1F007FFF80FFFF81E1E301C0E0038070038070038
+07003807003807001C0E001E1E001FFC001FF80039E0003800001C00001FFE001FFFC03F
+FFE07801F0700070E00038E00038E00038E000387800F07E03F01FFFC00FFF8001FC0015
+1F7F9318>I<7E0000FE00007E00000E00000E00000E00000E00000E00000E3E000EFF80
+0FFFC00FC1C00F80E00F00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E0
+0E00E00E00E00E00E07FC3FCFFE7FE7FC3FC171C809B18>I<03800007C00007C00007C0
+000380000000000000000000000000007FC000FFC0007FC00001C00001C00001C00001C0
+0001C00001C00001C00001C00001C00001C00001C00001C00001C00001C000FFFF00FFFF
+80FFFF00111D7C9C18>I<0038007C007C007C003800000000000000000FFC1FFC0FFC00
+1C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C001C00
+1C001C001C001C6038F078FFF07FE03F800E277E9C18>I<7FE000FFE0007FE00000E000
+00E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E000
+00E00000E00000E00000E00000E00000E00000E00000E00000E0007FFFC0FFFFE07FFFC0
+131C7E9B18>108 D<7CE0E000FFFBF8007FFFF8001F1F1C001E1E1C001E1E1C001C1C1C
+001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C
+001C1C1C007F1F1F00FFBFBF807F1F1F001914819318>I<7E3E00FEFF807FFFC00FC1C0
+0F80E00F00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E0
+0E00E07FC3FCFFE7FE7FC3FC1714809318>I<01F0000FFE001FFF003E0F803803807001
+C07001C0E000E0E000E0E000E0E000E0E000E0F001E07001C07803C03C07803E0F801FFF
+000FFE0001F00013147E9318>I<7E3E00FEFF807FFFC00FC1E00F80E00F00700E00700E
+00380E00380E00380E00380E00380E00380F00700F00700F80E00FC1E00FFFC00EFF800E
+3E000E00000E00000E00000E00000E00000E00000E00007FC000FFE0007FC000151E8093
+18>I<01E38007FB801FFF803E1F80380F80700780700780E00380E00380E00380E00380
+E00380E00380700780700780380F803C1F801FFF800FFB8003E380000380000380000380
+000380000380000380000380003FF8003FF8003FF8151E7E9318>I<7F87E0FF9FF07FBF
+F803F87803F03003E00003C00003C0000380000380000380000380000380000380000380
+000380000380007FFE00FFFF007FFE0015147F9318>I<07F7003FFF007FFF00780F00E0
+0700E00700E007007C00007FE0001FFC0003FE00001F00600780E00380E00380F00380F8
+0F00FFFF00FFFC00E7F00011147D9318>I<0180000380000380000380000380007FFFC0
+FFFFC0FFFFC0038000038000038000038000038000038000038000038000038000038040
+0380E00380E00380E001C1C001FFC000FF80003E0013197F9818>I<7E07E0FE0FE07E07
+E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00
+E00E01E00F03E007FFFC03FFFE01FCFC1714809318>I<7F8FF0FF8FF87F8FF01E03C00E
+03800E03800E0380070700070700070700038E00038E00038E00038E0001DC0001DC0001
+DC0000F80000F80000700015147F9318>I<FF8FF8FF8FF8FF8FF83800E03800E03800E0
+1C01C01C01C01C71C01CF9C01CF9C01CD9C01CD9C00DDD800DDD800DDD800D8D800F8F80
+0F8F8007070015147F9318>I<7F8FF07F9FF07F8FF0070700078E00039E0001DC0001F8
+0000F80000700000F00000F80001DC00039E00038E000707000F07807F8FF0FF8FF87F8F
+F015147F9318>I<7F8FF0FF8FF87F8FF00E01C00E03800E038007038007070007070003
+8700038600038E0001CE0001CE0000CC0000CC0000DC0000780000780000780000700000
+700000700000F00000E00079E0007BC0007F80003F00001E0000151E7F9318>I
+E /Fj 73 123 df<001F83E000F06E3001C078780380F8780300F0300700700007007000
+0700700007007000070070000700700007007000FFFFFF80070070000700700007007000
+070070000700700007007000070070000700700007007000070070000700700007007000
+0700700007007000070070000700700007007000070070007FE3FF001D20809F1B>11
+D<003F0000E0C001C0C00381E00701E00701E00700000700000700000700000700000700
+00FFFFE00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700
+E00700E00700E00700E00700E00700E00700E00700E07FC3FE1720809F19>I<001F81F8
+0000F04F040001C07C06000380F80F000300F00F000700F00F0007007000000700700000
+0700700000070070000007007000000700700000FFFFFFFF000700700700070070070007
+007007000700700700070070070007007007000700700700070070070007007007000700
+700700070070070007007007000700700700070070070007007007000700700700070070
+070007007007007FE3FE3FF02420809F26>14 D<7038F87CFC7EFC7E743A040204020402
+0804080410081008201040200F0E7E9F17>34 D<70F8FCFC74040404080810102040060E
+7C9F0D>39 D<0020004000800100020006000C000C001800180030003000300070006000
+60006000E000E000E000E000E000E000E000E000E000E000E000E0006000600060007000
+300030003000180018000C000C000600020001000080004000200B2E7DA112>I<800040
+002000100008000C00060006000300030001800180018001C000C000C000C000E000E000
+E000E000E000E000E000E000E000E000E000E000C000C000C001C0018001800180030003
+00060006000C00080010002000400080000B2E7DA112>I<70F8FCFC7404040408081010
+2040060E7C840D>44 D<FFC0FFC00A027F8A0F>I<70F8F8F87005057C840D>I<03F0000E
+1C001C0E00180600380700700380700380700380700380F003C0F003C0F003C0F003C0F0
+03C0F003C0F003C0F003C0F003C0F003C0F003C0F003C0F003C070038070038070038078
+07803807001806001C0E000E1C0003F000121F7E9D17>48 D<018003800F80F380038003
+800380038003800380038003800380038003800380038003800380038003800380038003
+80038003800380038007C0FFFE0F1E7C9D17>I<03F0000C1C00100E0020070040078080
+0780F007C0F803C0F803C0F803C02007C00007C0000780000780000F00000E00001C0000
+380000700000600000C0000180000300000600400C00401800401000803FFF807FFF80FF
+FF80121E7E9D17>I<03F0000C1C00100E00200F00780F80780780780780380F80000F80
+000F00000F00000E00001C0000380003F000003C00000E00000F000007800007800007C0
+2007C0F807C0F807C0F807C0F00780400780400F00200E001C3C0003F000121F7E9D17>
+I<000600000600000E00000E00001E00002E00002E00004E00008E00008E00010E00020E
+00020E00040E00080E00080E00100E00200E00200E00400E00C00E00FFFFF0000E00000E
+00000E00000E00000E00000E00000E0000FFE0141E7F9D17>I<1803001FFE001FFC001F
+F8001FE00010000010000010000010000010000010000011F000161C00180E0010070010
+07800003800003800003C00003C00003C07003C0F003C0F003C0E0038040038040070020
+0600100E000C380003E000121F7E9D17>I<007C000182000701000E03800C07801C0780
+380300380000780000700000700000F1F000F21C00F40600F80700F80380F80380F003C0
+F003C0F003C0F003C0F003C07003C07003C07003803803803807001807000C0E00061C00
+01F000121F7E9D17>I<4000007FFFC07FFF807FFF804001008002008002008004000008
+0000080000100000200000200000400000400000C00000C00001C0000180000380000380
+00038000038000078000078000078000078000078000078000078000030000121F7D9D17
+>I<03F0000C0C001006003003002001806001806001806001807001807803003E03003F
+06001FC8000FF00003F80007FC000C7E00103F00300F806003804001C0C001C0C000C0C0
+00C0C000C0C000806001802001001002000C0C0003F000121F7E9D17>I<03F0000E1800
+1C0C00380600380700700700700380F00380F00380F003C0F003C0F003C0F003C0F003C0
+7007C07007C03807C0180BC00E13C003E3C0000380000380000380000700300700780600
+780E00700C002018001070000FC000121F7E9D17>I<70F8F8F870000000000000000000
+0070F8F8F87005147C930D>I<70F8F8F8700000000000000000000070F0F8F878080808
+101010202040051D7C930D>I<0FC0307040384038E03CF03CF03C603C0038007000E000
+C001800180010003000200020002000200020002000000000000000000000007000F800F
+800F8007000E207D9F15>63 D<000100000003800000038000000380000007C0000007C0
+000007C0000009E0000009E0000009E0000010F0000010F0000010F00000207800002078
+000020780000403C0000403C0000403C0000801E0000801E0000FFFE0001000F0001000F
+0001000F00020007800200078002000780040003C00E0003C01F0007E0FFC03FFE1F207F
+9F22>65 D<FFFFE0000F80380007801E0007801F0007800F0007800F8007800F8007800F
+8007800F8007800F8007800F0007801F0007801E0007803C0007FFF00007803C0007801E
+0007800F0007800F8007800780078007C0078007C0078007C0078007C0078007C0078007
+8007800F8007800F0007801F000F803C00FFFFF0001A1F7E9E20>I<000FC040007030C0
+01C009C0038005C0070003C00E0001C01E0000C01C0000C03C0000C07C0000407C000040
+78000040F8000000F8000000F8000000F8000000F8000000F8000000F8000000F8000000
+F8000000780000007C0000407C0000403C0000401C0000401E0000800E00008007000100
+0380020001C0040000703800000FC0001A217D9F21>I<FFFFE0000F803C0007801E0007
+80070007800380078003C0078001E0078001E0078001F0078000F0078000F0078000F807
+8000F8078000F8078000F8078000F8078000F8078000F8078000F8078000F8078000F007
+8000F0078000F0078001E0078001E0078003C0078003800780070007800E000F803C00FF
+FFE0001D1F7E9E23>I<FFFFFF000F800F00078003000780030007800100078001800780
+00800780008007800080078080800780800007808000078080000781800007FF80000781
+800007808000078080000780800007808000078000200780002007800020078000400780
+004007800040078000C0078000C0078001800F800F80FFFFFF801B1F7E9E1F>I<FFFFFF
+000F800F0007800300078003000780010007800180078000800780008007800080078000
+80078080000780800007808000078080000781800007FF80000781800007808000078080
+000780800007808000078000000780000007800000078000000780000007800000078000
+00078000000FC00000FFFE0000191F7E9E1E>I<000FE0200078186000E004E0038002E0
+070001E00F0000E01E0000601E0000603C0000603C0000207C00002078000020F8000000
+F8000000F8000000F8000000F8000000F8000000F8000000F8007FFCF80003E0780001E0
+7C0001E03C0001E03C0001E01E0001E01E0001E00F0001E0070001E0038002E000E00460
+00781820000FE0001E217D9F24>I<FFF8FFF80F800F8007800F0007800F0007800F0007
+800F0007800F0007800F0007800F0007800F0007800F0007800F0007800F0007800F0007
+FFFF0007800F0007800F0007800F0007800F0007800F0007800F0007800F0007800F0007
+800F0007800F0007800F0007800F0007800F0007800F000F800F80FFF8FFF81D1F7E9E22
+>I<FFFC0FC0078007800780078007800780078007800780078007800780078007800780
+0780078007800780078007800780078007800780078007800FC0FFFC0E1F7F9E10>I<0F
+FFC0007C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C0000
+3C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C00203C00F8
+3C00F83C00F83C00F0380040780040700030E0000F800012207E9E17>I<FFFC0FFC0FC0
+03E007800180078001000780020007800400078008000780100007802000078040000780
+8000078100000783000007878000078F80000793C0000791E00007A1E00007C0F0000780
+F0000780780007803C0007803C0007801E0007801E0007800F0007800780078007800780
+07C00FC007E0FFFC3FFC1E1F7E9E23>I<FFFE000FC00007800007800007800007800007
+800007800007800007800007800007800007800007800007800007800007800007800007
+800007800007800207800207800207800207800607800407800407800C07801C0F807CFF
+FFFC171F7E9E1C>I<FF803FF807C007C007C0038005E0010005E0010004F00100047801
+0004780100043C0100043C0100041E0100040F0100040F010004078100040781000403C1
+000401E1000401E1000400F1000400F1000400790004003D0004003D0004001F0004001F
+0004000F0004000700040007000E0003001F000300FFE001001D1F7E9E22>78
+D<001F800000F0F00001C0380007801E000F000F000E0007001E0007803C0003C03C0003
+C07C0003E0780001E0780001E0F80001F0F80001F0F80001F0F80001F0F80001F0F80001
+F0F80001F0F80001F0F80001F0780001E07C0003E07C0003E03C0003C03C0003C01E0007
+800E0007000F000F0007801E0001C0380000F0F000001F80001C217D9F23>I<FFFFE000
+0F80780007801C0007801E0007800F0007800F8007800F8007800F8007800F8007800F80
+07800F8007800F0007801E0007801C000780780007FFE000078000000780000007800000
+078000000780000007800000078000000780000007800000078000000780000007800000
+078000000FC00000FFFC0000191F7E9E1F>I<FFFF80000F80F0000780780007803C0007
+801E0007801E0007801F0007801F0007801F0007801F0007801E0007801E0007803C0007
+8078000780F00007FF80000781C0000780E0000780F00007807000078078000780780007
+80780007807C0007807C0007807C0007807C0407807E0407803E040FC01E08FFFC0F1000
+0003E01E207E9E21>82 D<07E0800C1980100780300380600180600180E00180E00080E0
+0080E00080F00000F000007800007F00003FF0001FFC000FFE0003FF00001F8000078000
+03C00003C00001C08001C08001C08001C08001C0C00180C00380E00300F00600CE0C0081
+F80012217D9F19>I<7FFFFFE0780F01E0600F0060400F0020400F0020C00F0030800F00
+10800F0010800F0010800F0010000F0000000F0000000F0000000F0000000F0000000F00
+00000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F00
+00000F0000000F0000000F0000000F0000001F800007FFFE001C1F7E9E21>I<FFFC3FF8
+0FC007C00780038007800100078001000780010007800100078001000780010007800100
+078001000780010007800100078001000780010007800100078001000780010007800100
+0780010007800100078001000780010007800100038002000380020001C0020001C00400
+00E008000070180000382000000FC0001D207E9E22>I<FFF003FE1F8000F80F0000600F
+800060078000400780004003C0008003C0008003C0008001E0010001E0010001F0010000
+F0020000F0020000F806000078040000780400003C0800003C0800003C0800001E100000
+1E1000001F3000000F2000000F20000007C0000007C0000007C000000380000003800000
+038000000100001F207F9E22>I<FFF07FF81FF01F800FC007C00F00078003800F000780
+01000F0007C00100078007C00200078007C00200078007C0020003C009E0040003C009E0
+040003C009E0040003E010F00C0001E010F0080001E010F0080001F02078080000F02078
+100000F02078100000F0403C10000078403C20000078403C20000078C03E2000003C801E
+4000003C801E4000003C801E4000001F000F8000001F000F8000001F000F8000001E0007
+8000000E00070000000E00070000000C000300000004000200002C207F9E2F>I<7FF83F
+F80FE00FC007C0070003C0020001E0040001F00C0000F0080000781000007C1000003C20
+00003E4000001E4000000F8000000F8000000780000003C0000007E0000005E0000009F0
+000018F8000010780000207C0000603C0000401E0000801F0001800F0001000780020007
+C0070003C01F8007E0FFE01FFE1F1F7F9E22>I<08041008201020104020402080408040
+8040B85CFC7EFC7E7C3E381C0F0E7B9F17>92 D<081020204040808080B8FCFC7C38060E
+7D9F0D>96 D<1FE000303000781800781C00300E00000E00000E00000E0000FE00078E00
+1E0E00380E00780E00F00E10F00E10F00E10F01E10781E103867200F83C014147E9317>
+I<0E0000FE00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00
+000E3E000EC3800F01C00F00E00E00E00E00700E00700E00780E00780E00780E00780E00
+780E00780E00700E00700E00E00F00E00D01C00CC300083E0015207F9F19>I<03F80E0C
+1C1E381E380C70007000F000F000F000F000F000F00070007000380138011C020E0C03F0
+10147E9314>I<000380003F800003800003800003800003800003800003800003800003
+8000038000038003E380061B801C0780380380380380700380700380F00380F00380F003
+80F00380F00380F003807003807003803803803807801C07800E1B8003E3F815207E9F19
+>I<03F0000E1C001C0E00380700380700700700700380F00380F00380FFFF80F00000F0
+0000F000007000007000003800801800800C010007060001F80011147F9314>I<007C00
+C6018F038F07060700070007000700070007000700FFF007000700070007000700070007
+00070007000700070007000700070007000700070007007FF01020809F0E>I<0000E003
+E3300E3C301C1C30380E00780F00780F00780F00780F00780F00380E001C1C001E380033
+E0002000002000003000003000003FFE001FFF800FFFC03001E0600070C00030C00030C0
+0030C000306000603000C01C038003FC00141F7F9417>I<0E0000FE00000E00000E0000
+0E00000E00000E00000E00000E00000E00000E00000E00000E3E000E43000E81800F01C0
+0F01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C0
+0E01C00E01C00E01C0FFE7FC16207F9F19>I<1C003E003E003E001C0000000000000000
+00000000000E007E000E000E000E000E000E000E000E000E000E000E000E000E000E000E
+000E000E000E00FFC00A1F809E0C>I<00E001F001F001F000E000000000000000000000
+0000007007F000F000700070007000700070007000700070007000700070007000700070
+00700070007000700070007000706070F060F0C061803F000C28829E0E>I<0E0000FE00
+000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0FF00E03
+C00E03000E02000E04000E08000E10000E30000E70000EF8000F38000E1C000E1E000E0E
+000E07000E07800E03800E03C00E03E0FFCFF815207F9F18>I<0E00FE000E000E000E00
+0E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E00
+0E000E000E000E000E000E000E000E00FFE00B20809F0C>I<0E1F01F000FE618618000E
+81C81C000F00F00E000F00F00E000E00E00E000E00E00E000E00E00E000E00E00E000E00
+E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E0
+0E000E00E00E000E00E00E00FFE7FE7FE023147F9326>I<0E3E00FE43000E81800F01C0
+0F01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C0
+0E01C00E01C00E01C0FFE7FC16147F9319>I<01F800070E001C03803801C03801C07000
+E07000E0F000F0F000F0F000F0F000F0F000F0F000F07000E07000E03801C03801C01C03
+80070E0001F80014147F9317>I<0E3E00FEC3800F01C00F00E00E00E00E00F00E00700E
+00780E00780E00780E00780E00780E00780E00700E00F00E00E00F01E00F01C00EC3000E
+3E000E00000E00000E00000E00000E00000E00000E00000E0000FFE000151D7F9319>I<
+03E0800619801C05803C0780380380780380700380F00380F00380F00380F00380F00380
+F003807003807803803803803807801C0B800E138003E380000380000380000380000380
+000380000380000380000380003FF8151D7E9318>I<0E78FE8C0F1E0F1E0F0C0E000E00
+0E000E000E000E000E000E000E000E000E000E000E000E00FFE00F147F9312>I<1F9030
+704030C010C010C010E00078007F803FE00FF00070803880188018C018C018E030D0608F
+800D147E9312>I<020002000200060006000E000E003E00FFF80E000E000E000E000E00
+0E000E000E000E000E000E000E080E080E080E080E080610031001E00D1C7F9B12>I<0E
+01C0FE1FC00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E
+01C00E01C00E01C00E01C00E03C00603C0030DC001F1FC16147F9319>I<FF83F81E01E0
+1C00C00E00800E00800E008007010007010003820003820003820001C40001C40001EC00
+00E80000E80000700000700000700000200015147F9318>I<FF9FE1FC3C0780701C0300
+601C0380200E0380400E0380400E03C0400707C0800704C0800704E08003886100038871
+0003C8730001D0320001D03A0000F03C0000E01C0000E01C0000601800004008001E147F
+9321>I<7FC3FC0F01E00701C007018003810001C20000E40000EC00007800003800003C
+00007C00004E000087000107000303800201C00601E01E01E0FF07FE1714809318>I<FF
+83F81E01E01C00C00E00800E00800E008007010007010003820003820003820001C40001
+C40001EC0000E80000E800007000007000007000002000002000004000004000004000F0
+8000F08000F100006200003C0000151D7F9318>I<3FFF380E200E201C40384078407000
+E001E001C00380078007010E011E011C0338027006700EFFFE10147F9314>I
+E /Fk 3 54 df<03000700FF000700070007000700070007000700070007000700070007
+00070007000700070007007FF00C157E9412>49 D<00300030007000F001F00170027004
+7008701870107020704070C070FFFE0070007000700070007003FE0F157F9412>52
+D<20303FE03FC0240020002000200020002F8030E020700030003800384038E038E03880
+30406020C01F000D157E9412>I E /Fl 20 118 df<000E00001E00007E0007FE00FFFE
+00FFFE00F8FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE
+0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE
+0000FE0000FE0000FE0000FE0000FE0000FE0000FE007FFFFE7FFFFE7FFFFE17277BA622
+>49 D<00FF800003FFF0000FFFFC001F03FE003800FF007C007F80FE003FC0FF003FC0FF
+003FE0FF001FE0FF001FE07E001FE03C003FE000003FE000003FC000003FC000007F8000
+007F000000FE000000FC000001F8000003F0000003E00000078000000F0000001E000000
+3C00E0007000E000E000E001C001C0038001C0070001C00FFFFFC01FFFFFC03FFFFFC07F
+FFFFC0FFFFFF80FFFFFF80FFFFFF801B277DA622>I<007F800001FFF00007FFF8000FE0
+FC001F807E003F803F007F003F007F001F80FF001F80FF001FC0FF001FC0FF001FC0FF00
+1FE0FF001FE0FF001FE0FF001FE07F001FE07F003FE03F003FE01F807FE00F807FE007C1
+DFE003FF9FE0007E1FE000001FE000001FC000001FC000001FC000003F801F003F803F80
+3F003F803F003F807E003F807C001F01F8001E03F0000FFFE00007FF800001FE00001B27
+7DA622>57 D<1C003E007F00FF80FF80FF807F003E001C00000000000000000000000000
+0000000000001C003E007F00FF80FF80FF807F003E001C00091B7B9A13>I<01FFFFF001
+FFFFF001FFFFF00001FE000001FE000001FE000001FE000001FE000001FE000001FE0000
+01FE000001FE000001FE000001FE000001FE000001FE000001FE000001FE000001FE0000
+01FE000001FE000001FE000001FE000001FE000001FE000001FE000001FE000001FE0000
+01FE000001FE001801FE007E01FE00FF01FE00FF01FE00FF01FE00FF01FC007E03F8007C
+03F0003E0FE0000FFFC00003FE00001C297DA824>74 D<FFFE0000001FFFC0FFFE000000
+1FFFC0FFFF0000003FFFC003FF0000003FF00003FF0000003FF00003BF80000077F00003
+BF80000077F000039FC00000E7F000039FC00000E7F000038FE00001C7F000038FE00001
+C7F0000387F0000387F0000387F0000387F0000387F0000387F0000383F8000707F00003
+83F8000707F0000381FC000E07F0000381FC000E07F0000380FE001C07F0000380FE001C
+07F0000380FF003807F00003807F003807F00003807F003807F00003803F807007F00003
+803F807007F00003801FC0E007F00003801FC0E007F00003800FE1C007F00003800FE1C0
+07F00003800FE1C007F000038007F38007F000038007F38007F000038003FF0007F00003
+8003FF0007F000038001FE0007F000038001FE0007F000038000FC0007F000038000FC00
+07F000FFFE00FC01FFFFC0FFFE007801FFFFC0FFFE007801FFFFC03A297DA841>77
+D<007F806003FFF0E007FFF9E00F807FE01F001FE03E0007E07C0003E07C0001E0FC0001
+E0FC0001E0FC0000E0FE0000E0FE0000E0FF000000FFC000007FFE00007FFFE0003FFFFC
+001FFFFE000FFFFF8007FFFFC003FFFFE000FFFFE00007FFF000007FF000000FF8000007
+F8000003F8600001F8E00001F8E00001F8E00001F8F00001F0F00001F0F80003F0FC0003
+E0FF0007C0FFE01F80F3FFFF00E0FFFE00C01FF0001D297CA826>83
+D<7FFFFFFFFFC07FFFFFFFFFC07FFFFFFFFFC07F803FC03FC07E003FC007C078003FC003
+C078003FC003C070003FC001C0F0003FC001E0F0003FC001E0E0003FC000E0E0003FC000
+E0E0003FC000E0E0003FC000E0E0003FC000E000003FC0000000003FC0000000003FC000
+0000003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC000
+0000003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC000
+0000003FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC000
+0000003FC00000007FFFFFE000007FFFFFE000007FFFFFE0002B287EA730>I<001FF800
+00FFFE0003F01F0007E03F800FC03F801F803F803F801F007F800E007F0000007F000000
+FF000000FF000000FF000000FF000000FF000000FF000000FF0000007F0000007F000000
+7F8000003F8001C01F8001C00FC0038007E0070003F01E0000FFFC00001FE0001A1B7E9A
+1F>99 D<003FE00001FFF80003F07E0007C01F000F801F801F800F803F800FC07F000FC0
+7F0007C07F0007E0FF0007E0FF0007E0FFFFFFE0FFFFFFE0FF000000FF000000FF000000
+7F0000007F0000007F0000003F8000E01F8000E00FC001C007E0038003F81F0000FFFE00
+001FF0001B1B7E9A20>101 D<0007F0003FFC00FE3E01F87F03F87F03F07F07F07F07F0
+3E07F00007F00007F00007F00007F00007F00007F000FFFFC0FFFFC0FFFFC007F00007F0
+0007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F0
+0007F00007F00007F00007F00007F00007F00007F0007FFF807FFF807FFF80182A7EA915
+>I<00FF81F003FFE7F80FC1FE7C1F80FC7C1F007C383F007E107F007F007F007F007F00
+7F007F007F007F007F007F007F003F007E001F007C001F80FC000FC1F8001FFFE00018FF
+800038000000380000003C0000003E0000003FFFF8001FFFFF001FFFFF800FFFFFC007FF
+FFE01FFFFFF03E0007F07C0001F8F80000F8F80000F8F80000F8F80000F87C0001F03C00
+01E01F0007C00FC01F8003FFFE00007FF0001E287E9A22>I<FFE0000000FFE0000000FF
+E00000000FE00000000FE00000000FE00000000FE00000000FE00000000FE00000000FE0
+0000000FE00000000FE00000000FE00000000FE00000000FE00000000FE07F00000FE1FF
+C0000FE787E0000FEE03F0000FF803F0000FF803F8000FF003F8000FF003F8000FE003F8
+000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F800
+0FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000F
+E003F800FFFE3FFF80FFFE3FFF80FFFE3FFF80212A7DA926>I<07000F801FC03FE03FE0
+3FE01FC00F8007000000000000000000000000000000FFE0FFE0FFE00FE00FE00FE00FE0
+0FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0FFFE
+FFFEFFFE0F2B7DAA14>I<FFC07F800FF000FFC1FFE03FFC00FFC383F0707E000FC603F8
+C07F000FCC01F9803F000FD801FF003F800FF001FE003F800FF001FE003F800FE001FC00
+3F800FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F
+800FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F80
+0FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F80FF
+FE1FFFC3FFF8FFFE1FFFC3FFF8FFFE1FFFC3FFF8351B7D9A3A>109
+D<FFC07F0000FFC1FFC000FFC787E0000FCE03F0000FD803F0000FD803F8000FF003F800
+0FF003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000F
+E003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE0
+03F8000FE003F8000FE003F800FFFE3FFF80FFFE3FFF80FFFE3FFF80211B7D9A26>I<00
+3FE00001FFFC0003F07E000FC01F801F800FC03F800FE03F0007E07F0007F07F0007F07F
+0007F0FF0007F8FF0007F8FF0007F8FF0007F8FF0007F8FF0007F8FF0007F8FF0007F87F
+0007F07F0007F03F800FE03F800FE01F800FC00FC01F8007F07F0001FFFC00003FE0001D
+1B7E9A22>I<03FE300FFFF01E03F03800F0700070F00070F00070F80070FC0000FFE000
+7FFE007FFF803FFFE01FFFF007FFF800FFF80003FC0000FC60007CE0003CF0003CF00038
+F80038FC0070FF01E0F7FFC0C1FF00161B7E9A1B>115 D<007000007000007000007000
+00F00000F00000F00001F00003F00003F00007F0001FFFF0FFFFF0FFFFF007F00007F000
+07F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F038
+07F03807F03807F03807F03807F03803F03803F87001F86000FFC0001F8015267FA51B>
+I<FFE03FF800FFE03FF800FFE03FF8000FE003F8000FE003F8000FE003F8000FE003F800
+0FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000F
+E003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE0
+07F80007E007F80007E00FF80003F03BFF8001FFF3FF80003FC3FF80211B7D9A26>I
+E end
+%%EndProlog
+%%BeginSetup
+%%Feature: *Resolution 300dpi
+TeXDict begin
+
+%%EndSetup
+%%Page: 1 1
+1 0 bop 551 311 a Fl(The)23 b(Sc)n(heme)e(of)i(Things:)530
+407 y(The)f(June)h(1992)h(Meeting)1245 385 y Fk(1)751
+522 y Fj(Jonathan)15 b(Rees)715 579 y(Cornell)h(Univ)o(ersit)o(y)682
+635 y Fi(jar@cs.cornell.edu)220 796 y Fj(An)21 b(informally)i
+(constituted)e(group)g(of)g(p)q(eople)h(in)o(terested)g(in)g(the)f
+(future)g(of)149 852 y(the)f(Sc)o(heme)g(programming)f(language)h(met)g
+(at)f(the)g(Xero)o(x)g(P)o(alo)h(Alto)f(Researc)o(h)149
+909 y(Cen)o(ter)d(on)f(25)h(June)g(1992.)k(The)c(main)h(purp)q(ose)f
+(of)f(the)h(meeting)g(w)o(as)f(to)g(w)o(ork)g(on)149
+965 y(the)h(tec)o(hnical)g(con)o(ten)o(t)f(of)g(the)g(next)g(revision)i
+(of)d(the)i(Sc)o(heme)g(rep)q(ort.)220 1021 y(W)l(e)f(made)h(progress)e
+(on)h(sev)o(eral)h(fron)o(ts:)218 1112 y Fh(\017)22 b
+Fj(Some)15 b(di\013erences)i(with)e(the)g(IEEE)h(Sc)o(heme)g(standard)e
+(w)o(ere)h(resolv)o(ed.)218 1205 y Fh(\017)22 b Fj(Prop)q(osals)13
+b(for)g(m)o(ultiple)i(return)e(v)m(alues)i(and)e Fi(dynamic-wind)f
+Fj(w)o(ere)h(adopted.)218 1297 y Fh(\017)22 b Fj(A)15
+b(prop)q(osal)h(for)e(an)h Fi(eval)g Fj(pro)q(cedure)h(w)o(as)f
+(adopted.)218 1390 y Fh(\017)22 b Fj(The)d(high-lev)o(el)h(macro)e
+(facilit)o(y)h(describ)q(ed)h(in)g(the)e(Revised)1354
+1373 y Fk(4)1394 1390 y Fj(Rep)q(ort's)g(ap-)263 1446
+y(p)q(endix)f(will)g(b)q(e)f(mo)o(v)o(ed)e(in)o(to)i(the)f(rep)q(ort)g
+(prop)q(er.)220 1537 y(Tw)o(o)d(sub)q(committees)i(w)o(ere)e(formed:)19
+b(one)13 b(to)f(w)o(ork)g(on)h(exceptions,)h(and)f(one)g(to)149
+1593 y(c)o(harter)i(the)g(formation)f(of)h(a)g(standard)f(library)l(.)
+21 b(The)16 b(sub)q(committees)f(will)i(rep)q(ort)149
+1650 y(bac)o(k)f(to)e(the)h(group)g(with)h(prop)q(osals)f(for)g
+(inclusion)i(in)f(the)g(rep)q(ort.)220 1706 y(It)j(had)g(b)q(een)i(hop)
+q(ed)f(that)e(there)h(w)o(ould)h(b)q(e)g(progress)e(on)h(some)g(other)g
+(fron)o(ts)149 1763 y(\(user-de\014ned)e(t)o(yp)q(es,)e(dynamic)h
+(binding,)h(impro)o(v)o(emen)o(ts)e(to)f(\\rest")g(parameters\),)149
+1819 y(but)20 b(after)e(inconclusiv)o(e)j(discussion)g(these)e(topics)g
+(w)o(ere)g(dropp)q(ed.)32 b(These)19 b(topics)149 1876
+y(will)e(probably)f(b)q(e)g(tak)o(en)f(up)g(again)h(in)g(the)f(future.)
+220 1932 y(Norman)e(Adams)g(w)o(as)f(app)q(oin)o(ted)i(the)f(Revised)
+1068 1916 y Fk(5)1103 1932 y Fj(Rep)q(ort's)g(editor.)19
+b(It)13 b(is)h(hop)q(ed)149 1989 y(that)f(it)g(will)i(b)q(e)e(ready)g
+(b)o(y)g(early)h(1993,)e(so)g(as)h(to)f(precede)i(the)f(reconstitution)
+h(of)f(the)149 2045 y(IEEE)j(standard)f(group.)220 2102
+y(This)f(article)g(is)g(m)o(y)f(o)o(wn)g(in)o(terpretation)h(of)f(what)
+g(transpired,)h(and)g(should)g(not)149 2158 y(b)q(e)i(construed)g(as)f
+(de\014nitiv)o(e.)149 2277 y Fg(Agreemen)o(t)h(with)i(the)g(IEEE)g(Sc)o
+(heme)f(standard)149 2363 y Fj(Un)o(til)e(no)o(w,)f(the)g(Sc)o(heme)h
+(rep)q(orts)e(ha)o(v)o(e)h(encouraged)g(but)g(not)g(required)h(the)f
+(empt)o(y)149 2420 y(list)j Fi(\(\))e Fj(and)h(the)f(b)q(o)q(olean)i
+(false)f(v)m(alue)g Fi(#f)f Fj(to)g(b)q(e)i(distinct.)22
+b(It)15 b(has)g(b)q(een)i(the)f(in)o(ten)o(t)p 149 2453
+598 2 v 201 2480 a Ff(1)219 2496 y Fe(T)m(o)c(app)q(ear)i(in)g
+Fd(Lisp)f(Pointers)e Fe(V\(4\),)h(Octob)q(er{Decem)o(b)q(er)j(1992.)885
+2620 y Fj(1)p eop
+%%Page: 2 2
+2 1 bop 307 311 a Fj(ev)o(er)14 b(since)h(the)f(Revised)i(Revised)f
+(Rep)q(ort,)g(ho)o(w)o(ev)o(er,)e(that)g(this)h(distinction)i(w)o(ould)
+307 368 y(ev)o(en)o(tually)h(b)q(e)g(required.)25 b(The)16
+b(IEEE)h(Sc)o(heme)g(standard)f(bit)h(the)f(bullet)i(in)f(1990,)307
+424 y(and)f(no)o(w)e(the)i(Revised)721 408 y Fk(5)757
+424 y Fj(rep)q(ort)f(follo)o(ws.)378 482 y(The)20 b(standard)f(also)h
+(dropp)q(ed)h(the)f(distinction)i(b)q(et)o(w)o(een)e(essen)o(tial)h
+(and)f(not-)307 538 y(essen)o(tial)e(language)e(features;)h(most)f
+(features)g(that)g(w)o(ere)g(formerly)h(not)f(essen)o(tial,)307
+595 y(suc)o(h)11 b(as)f(n-ary)g Fi(+)g Fj(and)g Fi(apply)p
+Fj(,)g(are)g(no)o(w)g(required.)19 b(The)11 b(Revised)1427
+578 y Fk(5)1458 595 y Fj(Rep)q(ort)g(will)h(adopt)307
+651 y(this)18 b(stance,)g(at)f(least)h(as)g(regards)f(language)h
+(features)f(that)g(are)h(shared)f(with)h(the)307 708
+y(IEEE)h(standard.)30 b(Non-essen)o(tial)20 b(non-IEEE)g(o)q(ddities)g
+(suc)o(h)f(as)f Fi(transcript-on)307 764 y Fj(and)13
+b Fi(transcript-off)d Fj(and)i(the)h(prop)q(osed)f Fi
+(interaction-environment)d Fj(\(see)k(b)q(e-)307 821
+y(lo)o(w\))20 b(w)o(ere)f(not)h(discussed)h(at)e(the)h(meeting,)h(ho)o
+(w)o(ev)o(er,)f(and)g(consensus)g(on)g(their)307 877
+y(status)15 b(will)h(ha)o(v)o(e)f(to)g(b)q(e)h(reac)o(hed)f(via)h
+(electronic)g(mail.)378 935 y(A)g(third)h(asp)q(ect)g(of)f(the)g
+(standard)g(that)g(w)o(as)f(adopted)i(w)o(as)e(a)h(certain)h(obscure)
+307 991 y(paragraph)11 b(regarding)h(assignmen)o(ts)f(to)g(top-lev)o
+(el)i(v)m(ariables)g(\(section)f(6,)f(paragraph)307 1048
+y(2\).)19 b(The)12 b(e\013ect)h(of)f(this)h(is)g(that)f(if)i(a)e
+(program)f(con)o(tains)i(an)g(assignmen)o(t)f(to)g(an)o(y)h(top-)307
+1104 y(lev)o(el)j(v)m(ariable,)g(then)f(the)f(program)g(m)o(ust)g(con)o
+(tain)h(a)f Fi(define)g Fj(for)g(that)f(v)m(ariable;)j(it)307
+1161 y(is)e(not)f(su\016cien)o(t)i(that)d(the)i(v)m(ariable)h(b)q(e)f
+(b)q(ound.)20 b(This)14 b(has)g(b)q(een)g(the)g(case)f(for)g(most)307
+1217 y(v)m(ariables,)22 b(but)e(the)h(rule)f(applies)i(as)e(w)o(ell)h
+(to)e(v)m(ariables)i(suc)o(h)f(as)g Fi(car)g Fj(that)f(ha)o(v)o(e)307
+1274 y(built-in)h(bindings.)30 b(In)18 b(addition,)i(it)e(is)g
+(clari\014ed)h(that)f(if)g(a)f(program)g(mak)o(es)g(suc)o(h)307
+1330 y(a)d(de\014nition)i(or)e(assignmen)o(t,)g(then)h(the)f(b)q(eha)o
+(vior)h(of)f(built-in)j(pro)q(cedures)e(will)h(not)307
+1387 y(b)q(e)j(a\013ected.)28 b(F)l(or)17 b(example,)j(rede\014ning)f
+Fi(length)e Fj(cannot)h(a\013ect)f(the)h(b)q(eha)o(vior)h(of)307
+1443 y(the)14 b(built-in)j Fi(list->vector)c Fj(pro)q(cedure.)20
+b(If)14 b(in)i(some)d(particular)i(implemen)o(tation)307
+1500 y Fi(list->vector)f Fj(is)j(written)e(in)i(Sc)o(heme)f(and)g
+(calls)h Fi(length)p Fj(,)e(then)h(it)g(m)o(ust)f(b)q(e)h(sure)307
+1556 y(to)d(call)i(the)f(built-in)i Fi(length)d Fj(pro)q(cedure,)h(not)
+f(whatev)o(er)g(happ)q(ens)i(to)e(b)q(e)i(the)e(v)m(alue)307
+1612 y(of)i(the)g(v)m(ariable)i Fi(length)p Fj(.)307
+1740 y Fg(Multiple)i(return)e(v)m(alues)307 1828 y Fj(The)d
+Fi(call-with-values)d Fj(and)i Fi(values)f Fj(pro)q(cedures)i(w)o(ere)f
+(describ)q(ed)i(in)f(an)g(earlier)307 1885 y(Sc)o(heme)e(of)e(Things)h
+(\()p Fc(Lisp)h(Pointers)p Fj(,)e(v)o(olume)h(IV,)g(n)o(um)o(b)q(er)g
+(1\),)g(but)g(I'll)h(review)g(them)307 1941 y(here.)20
+b(The)c(follo)o(wing)g(is)g(adapted)f(from)f(John)i(Ramsdell's)g
+(concise)h(description:)421 2054 y Fi(\(values)23 b Fc(obje)n(ct)g
+Fb(:)8 b(:)g(:)n Fi(\))600 b Fj(essen)o(tial)16 b(pro)q(cedure)421
+2132 y Fi(values)e Fj(deliv)o(ers)j(all)f(of)f(its)g(argumen)o(ts)f(to)
+h(its)g(con)o(tin)o(uation.)421 2249 y Fi(\(call-with-values)21
+b Fc(thunk)j(r)n(e)n(c)n(eiver)o Fi(\))268 b Fj(essen)o(tial)16
+b(pro)q(cedure)421 2326 y Fi(call-with-values)c Fj(calls)j(its)f
+Fc(thunk)g Fj(argumen)o(t)g(with)g(a)g(con)o(tin)o(uation)h(that,)421
+2383 y(when)h(passed)g(some)f(v)m(alues,)i(calls)g(the)f
+Fc(r)n(e)n(c)n(eiver)e Fj(pro)q(cedure)j(with)f(those)g(v)m(al-)421
+2439 y(ues)22 b(as)g(argumen)o(ts.)40 b(The)23 b(con)o(tin)o(uation)f
+(for)g(the)g(call)h(to)f Fc(r)n(e)n(c)n(eiver)f Fj(is)h(the)421
+2496 y(con)o(tin)o(uation)15 b(of)g(the)g(call)i(to)d
+Fi(call-with-values)p Fj(.)1043 2620 y(2)p eop
+%%Page: 3 3
+3 2 bop 220 311 a Fj(Except)17 b(for)g(con)o(tin)o(uations)h(created)f
+(b)o(y)g(the)g Fi(call-with-values)e Fj(pro)q(cedure,)149
+368 y(all)21 b(con)o(tin)o(uations)g(tak)o(e)e(exactly)h(one)h(v)m
+(alue,)h(as)d(no)o(w;)j(the)e(e\013ect)g(of)f(passing)i(no)149
+424 y(v)m(alue)i(or)e(more)g(than)g(one)g(v)m(alue)i(to)d(con)o(tin)o
+(uations)i(that)f(w)o(ere)g(not)g(created)g(b)o(y)149
+481 y Fi(call-with-values)13 b Fj(is)j(unsp)q(eci\014ed)i(\(as)c
+(indeed)j(it)f(is)g(unsp)q(eci\014ed)h(no)o(w\).)220
+537 y Fi(values)d Fj(migh)o(t)h(b)q(e)h(de\014ned)h(as)e(follo)o(ws:)
+245 623 y Fi(\(define)23 b(\(values)g(.)g(things\))293
+679 y(\(call-with-current-cont)o(inuation)340 736 y(\(lambda)g
+(\(cont\))g(\(apply)g(cont)h(things\)\)\)\))149 822 y
+Fj(That)g(is,)j(the)d(pro)q(cedures)h(supplied)i(b)o(y)d
+Fi(call-with-current-continua)o(tion)149 878 y Fj(m)o(ust)18
+b(b)q(e)h(passed)g(the)f(same)g(n)o(um)o(b)q(er)h(of)f(argumen)o(ts)f
+(as)h(v)m(alues)i(exp)q(ected)f(b)o(y)g(the)149 934 y(con)o(tin)o
+(uation.)220 991 y(Because)14 b(the)g(b)q(eha)o(vior)g(of)g(a)f(n)o(um)
+o(b)q(er-of-v)m(alues)i(mismatc)o(h)f(b)q(et)o(w)o(een)g(a)f(con)o
+(tin-)149 1047 y(uation)f(and)g(its)f(in)o(v)o(ok)o(er)h(is)g(unsp)q
+(eci\014ed,)i(some)d(implemen)o(tations)i(ma)o(y)e(assign)g(some)149
+1104 y(sp)q(eci\014c)19 b(meaning)f(to)e(suc)o(h)h(situations;)h(for)f
+(example,)g(extra)g(v)m(alues)h(migh)o(t)f(b)q(e)g(ig-)149
+1160 y(nored,)f(or)f(defaults)h(migh)o(t)g(b)q(e)g(supplied)i(for)d
+(missing)i(v)m(alues.)22 b(Th)o(us)16 b(this)g(m)o(ultiple)149
+1217 y(return)k(v)m(alue)g(prop)q(osal)g(is)g(compatible)g(with)g
+(Common)f(Lisp's)h(m)o(ultiple)h(v)m(alues,)149 1273
+y(but)e(strictly)g(more)f(conserv)m(ativ)o(e)i(than)e(it.)30
+b(The)19 b(b)q(eha)o(vior)g(of)g(programs)e(in)i(suc)o(h)149
+1330 y(situations)e(w)o(as)e(a)h(p)q(oin)o(t)g(of)g(con)o(ten)o(tion)g
+(among)g(the)g(authors,)f(whic)o(h)i(is)f(wh)o(y)g(only)149
+1386 y(the)g(least)f(common)g(denominator)g(b)q(eha)o(vior)h(w)o(as)e
+(sp)q(eci\014ed.)149 1505 y Fg(Un)o(wind/wind)19 b(protection)149
+1590 y Fi(dynamic-wind)p Fj(,)13 b(whic)o(h)i(w)o(as)e(describ)q(ed)j
+(previously)f(in)g(this)g(column)g(\(when)f(it)h(w)o(as)149
+1647 y(The)k(Sc)o(heme)g(En)o(vironmen)o(t;)g Fc(Lisp)f(Pointers)p
+Fj(,)g(v)o(olume)g(I,)h(n)o(um)o(b)q(er)f(2\),)g(is)h(already)149
+1703 y(implemen)o(ted)24 b(in)f(man)o(y)e(Sc)o(heme)h(dialects.)41
+b Fi(dynamic-wind)20 b Fj(tak)o(es)h(three)h(argu-)149
+1760 y(men)o(ts,)15 b(all)h(of)f(whic)o(h)h(are)f(th)o(unks)h(\(pro)q
+(cedures)f(of)g(no)g(argumen)o(ts\).)k(It)d(b)q(eha)o(v)o(es)f(as)149
+1816 y(if)h(it)g(w)o(ere)e(de\014ned)j(with)245 1902
+y Fi(\(define)23 b(\(dynamic-wind)f(before)h(during)g(after\))293
+1958 y(\(before\))293 2015 y(\(call-with-values)e(during)340
+2071 y(\(lambda)i(results)388 2128 y(\(after\))388 2184
+y(\(apply)g(values)g(results\)\)\)\))149 2270 y Fj(except)17
+b(that)f(the)h(execution)g(of)f(the)h Fi(during)e Fj(th)o(unk)i(is)g
+(\\protected")e(against)h(non-)149 2326 y(lo)q(cal)e(en)o(tries)f(and)g
+(exits:)19 b(a)12 b(thro)o(w)g(out)g(of)g(the)h(execution)h(of)e
+Fi(during)g Fj(will)i(cause)f(the)149 2383 y Fi(after)h
+Fj(th)o(unk)g(to)f(b)q(e)i(in)o(v)o(ok)o(ed,)f(and)g(a)g(thro)o(w)e
+(from)i(outside)g(bac)o(k)g(in)h(will)g(cause)g(the)149
+2439 y Fi(before)10 b Fj(th)o(unk)h(to)f(b)q(e)h(in)o(v)o(ok)o(ed.)19
+b(\(By)10 b(\\thro)o(w")f(I)i(mean)g(an)g(in)o(v)o(o)q(cation)g(of)f
+(an)h(explicit)149 2496 y(con)o(tin)o(uation)16 b(as)f(obtained)h(from)
+e Fi(call-with-current-continuati)o(on)p Fj(.\))885 2620
+y(3)p eop
+%%Page: 4 4
+4 3 bop 378 311 a Fj(F)l(or)14 b(details,)h(the)f(earlier)i(Sc)o(heme)f
+(En)o(vironmen)o(t)g(column)g(refers)f(the)h(reader)f(to)307
+368 y(F)l(riedman)19 b(and)f(Ha)o(ynes's)f(pap)q(er)h(\\Constraining)g
+(Con)o(trol")f(in)i(POPL)f(1985,)f(but)307 424 y(to)h(sa)o(v)o(e)g(y)o
+(ou)h(the)g(trouble)g(of)g(lo)q(oking)g(that)f(up,)i(I)f(ha)o(v)o(e)g
+(supplied)i(a)d(more)h(direct)307 481 y(implemen)o(tation)e(of)d
+Fi(dynamic-wind)g Fj(in)i(an)f(app)q(endix)i(to)e(the)g(presen)o(t)g
+(column.)378 537 y Fi(dynamic-wind)9 b Fj(w)o(as)i(adopted)g(with)h
+(the)f(follo)o(wing)i(clari\014cations:)19 b(The)11 b(seman-)307
+594 y(tics)18 b(of)g Fi(\(dynamic-wind)k Fc(b)n(efor)n(e)h(during)h
+(after)p Fi(\))18 b Fj(should)h(lea)o(v)o(e)f(unsp)q(eci\014ed)i(what)
+307 650 y(happ)q(ens)i(if)g(a)f(thro)o(w)f(o)q(ccurs)i(out)f(of)f
+Fc(b)n(efor)n(e)h Fj(or)g Fc(after)5 b Fj(;)24 b(and)d(it)g(is)h(b)q
+(est)g(to)e(defer)307 707 y(in)o(terrupts)c(during)g
+Fc(b)n(efor)n(e)e Fj(and)i Fc(after)p Fj(.)307 827 y
+Fg(Ev)m(aluating)k(computed)e(expressions)307 913 y Fj(The)f(original)g
+(1975)f(memo)g(on)g(Sc)o(heme)h(describ)q(ed)h Fi(evaluate)p
+Fj(,)e(whic)o(h)h(w)o(as)e(analo-)307 970 y(gous)g(to)f(Lisp's)i
+(traditional)g Fi(eval)e Fj(function.)21 b Fi(evaluate)14
+b Fj(to)q(ok)g(a)h(single)i(argumen)o(t,)307 1026 y(an)e(S-expression,)
+h(and)g(in)o(v)o(ok)o(ed)f(an)g(in)o(terpreter)h(on)f(it.)20
+b(F)l(or)15 b(example:)403 1121 y Fi(\(let)23 b(\(\(name)g('+\)\))g
+(\(evaluate)g(\(list)g(name)g(2)h(3\)\)\))498 1177 y
+Fh(\000)-7 b(!)48 b Fi(5)307 1271 y Fj(Sc)o(heme)11 b(b)q(eing)h
+(lexically)h(scop)q(ed,)f(ho)o(w)o(ev)o(er,)e(there)g(w)o(as)g(some)g
+(confusion)h(o)o(v)o(er)f(whic)o(h)307 1328 y(en)o(vironmen)o(t)16
+b(the)f(expression)h(w)o(as)e(to)h(b)q(e)h(ev)m(aluated)g(in.)21
+b(Should)403 1422 y Fi(\(let)i(\(\(name)g('+\)\))450
+1479 y(\(let)h(\(\(+)f(*\)\))498 1535 y(\(evaluate)g(\(list)g(name)g(2)
+h(3\)\)\)\))307 1629 y Fj(ev)m(aluate)16 b(to)f(5)g(or)f(to)h(6?)378
+1686 y(T)l(o)c(clarify)i(matters,)d(the)i(Revised)h(Rep)q(ort)f
+(replaced)h Fi(evaluate)e Fj(with)h Fi(enclose)p Fj(,)307
+1742 y(whic)o(h)k(to)q(ok)f(t)o(w)o(o)f(argumen)o(ts,)h(a)g
+Fi(lambda)p Fj(-expression)g(and)h(a)f(represen)o(tation)h(of)f(an)307
+1799 y(en)o(vironmen)o(t)h(from)f(whic)o(h)h(to)f(supply)h(bindings)i
+(of)d(the)g Fi(lambda)p Fj(-expression's)g(free)307 1855
+y(v)m(ariables.)21 b(F)l(or)15 b(example:)403 1950 y
+Fi(\(let)23 b(\(\(name)g('+\)\))450 2006 y(\(let)h(\(\(+)f(*\)\))498
+2063 y(\(\(enclose)g(\(list)g('lambda)g('\(\))g(\(list)g(name)h(2)f
+(3\)\))737 2119 y(\(list)g(\(cons)g('+)h(+\)\)\)\)\)\))498
+2176 y Fh(\000)-7 b(!)48 b Fi(6)307 2270 y Fj(This)20
+b(forced)g(the)g(programmer)e(to)h(b)q(e)i(explicit)h(ab)q(out)d(the)h
+Fi(lambda)p Fj(-expression's)307 2326 y(enclosing)d(en)o(vironmen)o(t.)
+378 2383 y(F)l(or)d(v)m(arious)h(tec)o(hnical)i(and)e(practical)g
+(reasons,)f(there)h(w)o(as)f(no)h Fi(eval)f Fj(analogue)307
+2439 y(in)21 b(subsequen)o(t)g(Sc)o(heme)f(rep)q(orts.)34
+b(The)20 b(ma)s(jor)f(stum)o(bling)h(blo)q(c)o(ks)h(w)o(ere)f(ho)o(w)f
+(to)307 2496 y(describ)q(e)j Fi(eval)d Fj(formally)h(and)g(ho)o(w)g(to)
+f(de\014ne)i(something)f(that)f(mak)o(es)g(sense)i(in)1043
+2620 y(4)p eop
+%%Page: 5 5
+5 4 bop 149 311 a Fj(all)17 b(extan)o(t)f(v)m(arian)o(ts)g(of)f(the)h
+(language.)23 b(Some)16 b(Sc)o(heme)g(implemen)o(tations)i(con)o(tain)
+149 368 y(a)e(distinguished)i(top-lev)o(el)f(en)o(vironmen)o(t,)e
+(while)i(others)e(extend)h(the)g(language)g(b)o(y)149
+424 y(pro)o(viding)j(w)o(a)o(ys)e(to)g(create)g(m)o(ultiple)j(en)o
+(vironmen)o(ts,)e(an)o(y)g(of)f(whic)o(h)h(migh)o(t)g(serv)o(e)149
+481 y(equally)f(w)o(ell.)220 537 y(The)12 b Fi(eval)g
+Fj(prop)q(osal)g(adopted)g(at)g(the)g(June)h(meeting,)g(whic)o(h)f(I)h
+(repro)q(duce)g(here,)149 594 y(is)j(one)f(that)g(comes)g(from)g(Bill)i
+(Rozas.)263 702 y Fi(\(eval)23 b Fc(expr)n(ession)g(envir)n(onment-sp)n
+(e)n(ci\014er)m Fi(\))190 b Fj(essen)o(tial)16 b(pro)q(cedure)263
+777 y Fi(eval)10 b Fj(ev)m(aluates)h Fc(expr)n(ession)e
+Fj(in)h(the)h(en)o(vironmen)o(t)f(indicated)i(b)o(y)e
+Fc(envir)n(onment-)263 834 y(sp)n(e)n(ci\014er)p Fj(.)21
+b Fc(envir)n(onment-sp)n(e)n(ci\014er)13 b Fj(ma)o(y)i(b)q(e)i(the)f
+(return)g(v)m(alue)h(of)e(one)h(of)g(the)263 890 y(three)21
+b(pro)q(cedures)g(describ)q(ed)h(b)q(elo)o(w,)g(or)e(implemen)o
+(tation-sp)q(eci\014c)j(exten-)263 947 y(sions.)31 b(No)19
+b(other)g(op)q(erations)g(on)f(en)o(vironmen)o(t)i(sp)q(eci\014ers)g
+(are)f(de\014ned)h(b)o(y)263 1003 y(this)c(prop)q(osal.)263
+1079 y(Implemen)o(tations)g(ma)o(y)e(allo)o(w)h(non-expression)h
+(programs)e(\(i.e.)g(de\014nitions\))263 1135 y(as)j(the)h(\014rst)f
+(argumen)o(t)g(to)g Fi(eval)g Fc(only)h Fj(when)g(the)f(second)i
+(argumen)o(t)e(is)h(the)263 1192 y(return)i(v)m(alue)h(of)f
+Fi(interaction-environment)d Fj(or)j(some)f(implemen)o(tation)263
+1248 y(extension.)i(In)16 b(other)e(w)o(ords,)g Fi(eval)h
+Fj(will)i(nev)o(er)e(create)g(new)h(bindings)h(in)f(the)263
+1305 y(return)f(v)m(alue)i(of)d Fi(null-environment)f
+Fj(or)i Fi(scheme-report-environment)p Fj(.)263 1420
+y Fi(\(scheme-report-environment)20 b Fc(version)p Fi(\))193
+b Fj(essen)o(tial)16 b(pro)q(cedure)263 1495 y Fc(V)m(ersion)21
+b Fj(m)o(ust)i(b)q(e)g(an)g(exact)f(non-negativ)o(e)h(in)o(teger)g
+(corresp)q(onding)h(to)e(a)263 1552 y(v)o(ersion)e(of)f(one)h(of)f(the)
+h(Revised)857 1535 y Fa(n)902 1552 y Fj(Rep)q(orts)g(on)g(Sc)o(heme.)34
+b(This)20 b(pro)q(cedure)263 1608 y(returns)g(a)g(sp)q(eci\014er)h(for)
+f(an)g(en)o(vironmen)o(t)g(that)f(con)o(tains)i(exactly)f(the)g(set)263
+1665 y(of)d(bindings)i(sp)q(eci\014ed)g(in)f(the)g(corresp)q(onding)g
+(rep)q(ort)f(that)f(the)i(implemen-)263 1721 y(tation)h(supp)q(orts.)32
+b(Not)18 b(all)i(v)o(ersions)g(ma)o(y)e(b)q(e)i(a)o(v)m(ailable)h(in)f
+(all)g(implemen-)263 1778 y(tations)g(at)f(all)i(times.)35
+b(Ho)o(w)o(ev)o(er,)20 b(an)g(implemen)o(tation)i(that)d(conforms)g(to)
+263 1834 y(v)o(ersion)e Fb(n)g Fj(of)f(the)h(Revised)748
+1818 y Fa(n)789 1834 y Fj(Rep)q(orts)g(on)g(Sc)o(heme)g(m)o(ust)f
+(accept)h(v)o(ersion)g Fb(n)p Fj(.)263 1891 y(If)e Fi
+(scheme-report-environmen)o(t)d Fj(is)i(a)o(v)m(ailable,)i(but)f(the)f
+(sp)q(eci\014ed)j(v)o(ersion)263 1947 y(is)f(not,)e(the)i(pro)q(cedure)
+g(will)g(signal)h(an)e(error.)263 2023 y(The)e(e\013ect)g(of)f
+(assigning)i(\(through)e(the)h(use)g(of)g Fi(eval)p Fj(\))f(a)g(v)m
+(ariable)j(b)q(ound)e(in)h(a)263 2079 y Fi(scheme-report-environment)8
+b Fj(\(e.g.)j Fi(car)p Fj(\))f(is)i(unsp)q(eci\014ed.)22
+b(Th)o(us)11 b(the)h(en)o(vi-)263 2136 y(ronmen)o(ts)e(sp)q(eci\014ed)i
+(b)o(y)e(the)g(return)g(v)m(alues)i(of)d Fi(scheme-report-environment)
+263 2192 y Fj(ma)o(y)15 b(b)q(e)g(imm)o(utable.)263 2307
+y Fi(\(null-environment\))572 b Fj(essen)o(tial)16 b(pro)q(cedure)263
+2383 y(This)d(pro)q(cedure)h(returns)f(a)f(sp)q(eci\014er)j(for)d(an)h
+(en)o(vironmen)o(t)g(that)f(con)o(tains)h(no)263 2439
+y(v)m(ariable)f(bindings,)g(but)f(con)o(tains)f(\(syn)o(tactic\))g
+(bindings)i(for)d(all)j(the)e(syn)o(tactic)263 2496 y(k)o(eyw)o(ords)k
+(de\014ned)j(in)f(the)f(rep)q(ort,)g(and)g(no)g(others.)885
+2620 y(5)p eop
+%%Page: 6 6
+6 5 bop 421 311 a Fi(\(interaction-environment\))585
+b Fj(pro)q(cedure)421 387 y(This)20 b(pro)q(cedure)g(returns)g(a)f(sp)q
+(eci\014er)i(for)e(an)h(en)o(vironmen)o(t)g(that)e(con)o(tains)421
+444 y(implementation-de\014ned)k(bindings,)e(t)o(ypically)g(a)f(sup)q
+(erset)g(of)f(those)g(listed)421 500 y(in)h(the)g(rep)q(ort.)30
+b(The)19 b(in)o(ten)o(t)g(is)h(that)e(this)h(pro)q(cedure)g(will)i
+(return)e(a)f(sp)q(eci-)421 557 y(\014er)f(for)e(the)i(en)o(vironmen)o
+(t)g(in)g(whic)o(h)g(the)g(implemen)o(tation)h(w)o(ould)f(ev)m(aluate)
+421 613 y(expressions)f(dynamically)h(t)o(yp)q(ed)e(b)o(y)h(the)f
+(user.)378 722 y(Rozas)c(explains:)19 b(\\The)11 b(prop)q(osal)g(do)q
+(es)g(not)g(imply)h(the)f(existence)h(or)f(supp)q(ort)g(of)307
+778 y(\014rst-class)j(en)o(vironmen)o(ts,)g(although)h(it)f(is)g
+(compatible)h(with)g(them.)k(The)14 b(prop)q(osal)307
+835 y(only)22 b(requires)g(a)f(w)o(a)o(y)f(of)h(asso)q(ciating)h(tags)e
+(with)i(a)f(\014nite)h(set)f(of)g(distinguished)307 891
+y(en)o(vironmen)o(ts)d(whic)o(h)g(the)f(implemen)o(tations)i(can)f
+(main)o(tain)f(implicitl)q(y)j(\(without)307 947 y(rei\014cation\).)378
+1004 y(\\)7 b(`P)o(ascal-lik)o(e')k(implemen)o(tations)h(can)f(supp)q
+(ort)f(b)q(oth)h Fi(null-environment)d Fj(and)307 1061
+y Fi(scheme-report-environment)f Fj(since)k(the)g(en)o(vironmen)o(ts)f
+(sp)q(eci\014ed)i(b)o(y)e(the)h(return)307 1117 y(v)m(alues)j(of)e
+(these)g(pro)q(cedures)i(need)f(not)f(share)h(an)o(y)f(bindings)i(with)
+f(the)f(curren)o(t)h(pro-)307 1174 y(gram.)k(A)11 b(v)o(ersion)f(of)g
+Fi(eval)f Fj(that)h(supp)q(orts)g(these)g(but)h(not)e
+Fi(interaction-environment)307 1230 y Fj(can)j(b)q(e)g(written)g(p)q
+(ortably)l(,)h(but)e(can)h(b)q(e)h(b)q(etter)e(written)h(b)o(y)g(the)g
+(implemen)o(tor,)g(since)307 1287 y(it)k(can)f(share)g(co)q(de)h(with)f
+(the)h(default)f(ev)m(aluator)h(or)e(compiler.")378 1343
+y(Here)f(\\P)o(ascal-lik)o(e")i(refers)e(to)g(implemen)o(tations)h
+(that)f(are)g(restricted)h(to)f(static)307 1400 y(compilation)f(and)e
+(linking.)20 b(Because)11 b(an)f Fi(eval)g Fj(that)f(do)q(esn't)h(supp)
+q(ort)g Fi(interaction-)307 1456 y(environment)15 b Fj(can)i(b)q(e)h
+(written)e(en)o(tirely)i(in)g(the)f(Sc)o(heme)g(language)g(describ)q
+(ed)i(b)o(y)307 1513 y(the)g(rest)f(of)f(the)i(rep)q(ort,)f(it)h
+(raises)f(no)h(troublesome)f(questions)h(ab)q(out)f(its)h(formal)307
+1569 y(seman)o(tics.)307 1692 y Fg(Macros)307 1778 y
+Fj(The)11 b(consensus)g(of)f(the)g(meeting)h(w)o(as)e(that)h
+Fi(define-syntax)p Fj(,)f Fi(syntax-rules)p Fj(,)g Fi(let-)307
+1835 y(syntax)p Fj(,)14 b(and)h Fi(letrec-syntax)f Fj(should)i(b)q(e)g
+(mo)o(v)o(ed)f(out)f(of)h(the)g(rep)q(ort's)g(app)q(endix)307
+1891 y(in)o(to)e(the)h(main)g(b)q(o)q(dy)g(of)e(the)i(rep)q(ort.)19
+b(Although)14 b(ev)o(ery)o(one)f(agrees)g(that)f(a)h(lo)o(w-lev)o(el)
+307 1948 y(macro)j(facilit)o(y)i(is)f(imp)q(ortan)o(t,)g(the)g(sub)s
+(ject)f(is)h(to)q(o)g(con)o(ten)o(tious)f(at)g(presen)o(t,)h(with)307
+2004 y(three)h(or)f(more)g(comp)q(eting)h(prop)q(osals)f(at)g(presen)o
+(t.)27 b(The)17 b(disp)q(osition)i(of)e(the)h(rest)307
+2061 y(of)f(the)h(app)q(endix)h(and)f(of)f(the)g(other)g(lo)o(w-lev)o
+(el)i(prop)q(osals)f(will)h(b)q(e)f(left)g(up)g(to)e(the)307
+2117 y(rep)q(ort's)f(editor.)307 2240 y Fg(Committee)j(w)o(ork)307
+2326 y Fj(There)c(is)h(a)e(strong)g(sense)i(that)e(some)h(kind)h(of)e
+(exception)i(system)f(is)g(needed.)21 b(Ho)o(w-)307 2383
+y(ev)o(er,)15 b(no)g(sp)q(eci\014c)i(prop)q(osal)e(w)o(as)f(ready)h(at)
+g(the)g(time)g(of)g(the)g(meeting.)20 b(A)15 b(commit-)307
+2439 y(tee)k(has)g(b)q(een)g(formed)g(to)f(w)o(ork)g(on)g(one.)31
+b(What)18 b(seems)h(to)f(b)q(e)h(in)h(the)f(air)g(migh)o(t)307
+2496 y(b)q(e)d(describ)q(ed)h(as)d(a)h(highly)i(distilled)g(v)o(ersion)
+f(of)e(the)h(condition)h(system)f(that)f(Ken)o(t)1043
+2620 y(6)p eop
+%%Page: 7 7
+7 6 bop 149 311 a Fj(Pitman)18 b(dev)o(elop)q(ed)h(for)d(Common)h
+(Lisp.)27 b(I)18 b(hop)q(e)g(that)f(I'll)h(b)q(e)g(able)g(to)f(rep)q
+(ort)g(on)149 368 y(this)f(in)g(a)f(future)g(column.)220
+424 y(On)i(the)f(sub)s(ject)g(of)g(libraries,)i(Will)g(Clinger's)e(min)
+o(utes)h(rep)q(ort)f(that)g(\\the)g(au-)149 481 y(thors)h(p)q(erceiv)o
+(e)i(a)e(need)i(to)d(giv)o(e)i(some)f(library)i(o\016cial)f(status.)26
+b(In)18 b(fact,)f(w)o(e)g(need)149 537 y(to)e(giv)o(e)h(o\016cial)h
+(sanction)f(to)f(m)o(ultiple)i(libraries.)23 b(There)16
+b(is)g(reason)g(to)f(distinguish)149 594 y(b)q(et)o(w)o(een)d(accepted)
+f(\(or)g(standard\))f(libraries,)j(exp)q(erimen)o(tal)f(libraries,)i
+(and)d(prop)q(os-)149 650 y(als.)26 b(The)17 b(accepted)h(libraries)g
+(can)g(reduce)g(the)f(in)o(tellectual)i(size)f(of)e(the)i(language)149
+707 y(b)o(y)g(remo)o(ving)f(things)g(lik)o(e)h Fi(string->list)e
+Fj(from)g(the)i(rep)q(ort.)25 b(The)17 b(exp)q(erimen)o(tal)149
+763 y(libraries)i(w)o(ould)f(con)o(tain)g(solid)g(implemen)o(tations)h
+(of)e(exp)q(erimen)o(tal)i(features,)e(in-)149 819 y(cluding)i(things)e
+(that)g(migh)o(t)f(nev)o(er)h(deserv)o(e)g(to)g(b)q(e)g(in)h(the)f(rep)
+q(ort.)24 b(The)18 b(prop)q(osal)149 876 y(libraries)f(could)f(con)o
+(tain)g(an)o(ything)f(implemen)o(ted)i(in)f(p)q(ortable)g(Sc)o(heme.")
+220 932 y(Among)11 b(the)g(con)o(ten)o(t)g(of)g(the)g(accepted)h
+(libraries,)h(some)e(features)g(\(suc)o(h)g(as)g(those)149
+989 y(that)18 b(ma)o(y)f(b)q(e)h(mo)o(v)o(ed)g(out)f(of)h(the)g(b)q(o)q
+(dy)g(of)g(the)g(rep)q(ort\))f(ma)o(y)g(b)q(e)i(required)g(to)e(b)q(e)
+149 1045 y(built)e(in)f(to)f(implemen)o(tations,)h(while)h(others)e
+(will)i(b)q(e)f(exp)q(ected)g(to)f(b)q(e)h(a)o(v)m(ailable)h(on)149
+1102 y(demand)g(\(p)q(erhaps)f(using)h(something)g(similar)g(to,)e(but)
+i(not)e(the)h(same)g(as,)g Fi(require)149 1158 y Fj(as)h(found)h(in)g
+(Common)e(Lisp)j(and)e(GNU)g(Emacs\).)220 1215 y(A)f(librarian)h(w)o
+(as)d(app)q(oin)o(ted)j(\(Rees\),)e(and)h(a)f(library)i(committee)e(is)
+h(dev)o(eloping)149 1271 y(prop)q(osals)i(for)e(the)i(c)o(harter,)e
+(structure,)g(and)i(con)o(ten)o(t)e(of)h(the)g(libraries.)817
+1394 y Fh(\003)45 b(\003)g(\003)220 1517 y Fj(I)17 b(w)o(ould)g(lik)o
+(e)h(to)e(ac)o(kno)o(wledge)h(Will)h(Clinger,)g(who)e(prepared)h(the)g
+(min)o(utes)g(of)149 1574 y(the)i(meeting,)g(and)g(the)g(v)m(arious)g
+(p)q(eople)h(who)e(con)o(tributed)h(prop)q(osals,)g(including)149
+1630 y(Bill)f(Rozas)d(and)h(John)f(Ramsdell.)22 b(An)o(y)15
+b(errors)g(here)h(are)f(m)o(y)g(resp)q(onsibilit)o(y)l(,)i(ho)o(w-)149
+1687 y(ev)o(er.)j(Thanks)15 b(also)g(to)f(Norman)g(Adams)h(and)g(Ric)o
+(hard)h(Kelsey)g(for)e(corrections)h(to)149 1743 y(a)g(draft)g(of)g
+(this)g(article.)220 1799 y(I)i(w)o(ould)g(also)g(lik)o(e)h(to)f(b)q
+(elatedly)h(ac)o(kno)o(wledge)f(Norman)g(Adams,)f(P)o(a)o(v)o(el)h
+(Cur-)149 1856 y(tis,)g(Bruce)g(Donald,)f(and)h(Ric)o(hard)g(Kelsey)g
+(for)f(their)h(commen)o(ts)f(on)g(drafts)f(of)h(m)o(y)149
+1912 y(previous)g(column.)220 1969 y(F)l(or)e(future)g(columns,)h(I)g
+(am)f(en)o(tertaining)h(v)m(arious)g(topic)g(p)q(ossibilities,)i
+(includ-)149 2025 y(ing)h Fi(eval)p Fj(,)e(threads,)g
+Fi(amb)p Fj(,)g(and)h(monads.)24 b(If)17 b(y)o(ou)f(ha)o(v)o(e)h(other)
+f(ideas,)h(and)g(particu-)149 2082 y(larly)f(if)g(y)o(ou)e(think)i(the)
+f(written)h(record)f(on)g(the)g(language)g(is)h(particularly)g(p)q(o)q
+(or)f(in)149 2138 y(certain)h(areas,)e(please)i(write)g(and)f(let)h(me)
+f(kno)o(w.)149 2297 y Fg(App)q(endix:)23 b(An)17 b(implemen)o(tation)i
+(of)f Fi(dynamic-wind)149 2383 y Fj(This)c(program)e(is)h(based)g(on)g
+(m)o(y)g(v)m(ague)g(recollection)i(of)d(an)h(ancien)o(t)h(man)o
+(uscript)f(b)o(y)149 2439 y(Chris)k(Hanson)f(and)h(John)g(Lamping.)24
+b(I)17 b(ap)q(ologize)g(for)f(the)g(lac)o(k)h(of)f(data)f(abstrac-)149
+2496 y(tion,)h(but)f(the)g(co)q(de)h(is)g(more)e(concise)j(this)e(w)o
+(a)o(y)l(.)885 2620 y(7)p eop
+%%Page: 8 8
+8 7 bop 378 311 a Fj(A)11 b(state)f(space)h(is)h(a)f(tree)g(with)g(the)
+g(curren)o(t)g(state)f(at)h(the)g(ro)q(ot.)17 b(Eac)o(h)11
+b(no)q(de)h(other)307 368 y(than)i(the)f(ro)q(ot)g(is)h(a)g(triple)g
+Fh(h)p Fc(b)n(efor)n(e)o Fb(;)8 b Fc(after)p Fb(;)g Fc(p)n(ar)n(ent)o
+Fh(i)p Fj(,)13 b(represen)o(ted)h(in)g(this)h(implemen-)307
+424 y(tation)e(as)f(t)o(w)o(o)g(pairs)h Fi(\(\()p Fc(b)n(efor)n(e)23
+b Fi(.)h Fc(after)p Fi(\))g(.)g Fc(p)n(ar)n(ent)o Fi(\))p
+Fj(.)19 b(Na)o(vigating)13 b(b)q(et)o(w)o(een)g(states)307
+481 y(requires)j(re-ro)q(oting)f(the)h(tree)f(b)o(y)g(rev)o(ersing)g
+(paren)o(t-c)o(hild)i(links.)378 537 y(Since)c Fi(dynamic-wind)d
+Fj(in)o(teracts)h(with)h Fi(call-with-current-continua)o(tion)p
+Fj(,)307 594 y(this)k(implemen)o(tation)g(m)o(ust)f(replace)h(the)f
+(usual)h(de\014nition)h(of)e(the)g(latter.)307 700 y
+Fi(\(define)23 b(*here*)g(\(list)g(#f\)\))307 795 y(\(define)g
+(original-cwcc)f(call-with-current-continuat)o(ion\))307
+891 y(\(define)h(\(call-with-current-continua)o(tion)e(proc\))355
+948 y(\(let)i(\(\(here)g(*here*\)\))403 1004 y(\(original-cwcc)f
+(\(lambda)g(\(cont\))808 1060 y(\(proc)h(\(lambda)g(results)999
+1117 y(\(reroot!)g(here\))999 1173 y(\(apply)g(cont)h
+(results\)\)\)\)\)\)\))307 1269 y(\(define)f(\(dynamic-wind)f(before)h
+(during)g(after\))355 1325 y(\(let)g(\(\(here)g(*here*\)\))403
+1382 y(\(reroot!)f(\(cons)i(\(cons)f(before)g(after\))g(here\)\))403
+1438 y(\(call-with-values)e(during)450 1495 y(\(lambda)i(results)498
+1551 y(\(reroot!)g(here\))498 1608 y(\(apply)g(values)g
+(results\)\)\)\)\))307 1703 y(\(define)g(\(reroot!)g(there\))355
+1760 y(\(if)g(\(not)h(\(eq?)f(*here*)g(there\)\))450
+1816 y(\(begin)g(\(reroot!)g(\(cdr)g(there\)\))617 1873
+y(\(let)h(\(\(before)e(\(caar)i(there\)\))761 1929 y(\(after)f(\(cdar)g
+(there\)\)\))665 1986 y(\(set-car!)g(*here*)g(\(cons)g(after)g
+(before\)\))665 2042 y(\(set-cdr!)g(*here*)g(there\))665
+2098 y(\(set-car!)g(there)g(#f\))665 2155 y(\(set-cdr!)g(there)g
+('\(\)\))665 2211 y(\(set!)g(*here*)g(there\))665 2268
+y(\(before\)\)\)\)\))1043 2620 y Fj(8)p eop
+%%Trailer
+end
+userdict /end-hook known{end-hook}if
+%%EOF
diff --git a/doc/module.ps b/doc/module.ps
new file mode 100644
index 0000000..9ef281b
--- /dev/null
+++ b/doc/module.ps
@@ -0,0 +1,1417 @@
+%!PS-Adobe-2.0
+%%Creator: dvips 5.521 Copyright 1986, 1993 Radical Eye Software
+%%CreationDate: Sat Jan 15 16:16:41 1994
+%%Pages: 14
+%%PageOrder: Ascend
+%%BoundingBox: 0 0 612 792
+%%EndComments
+%DVIPSCommandLine: dvips -f
+%DVIPSSource:  TeX output 1994.01.15:1616
+%%BeginProcSet: tex.pro
+/TeXDict 250 dict def TeXDict begin /N{def}def /B{bind def}N /S{exch}N
+/X{S N}B /TR{translate}N /isls false N /vsize 11 72 mul N /hsize 8.5 72
+mul N /landplus90{false}def /@rigin{isls{[0 landplus90{1 -1}{-1 1}
+ifelse 0 0 0]concat}if 72 Resolution div 72 VResolution div neg scale
+isls{landplus90{VResolution 72 div vsize mul 0 exch}{Resolution -72 div
+hsize mul 0}ifelse TR}if Resolution VResolution vsize -72 div 1 add mul
+TR matrix currentmatrix dup dup 4 get round 4 exch put dup dup 5 get
+round 5 exch put setmatrix}N /@landscape{/isls true N}B /@manualfeed{
+statusdict /manualfeed true put}B /@copies{/#copies X}B /FMat[1 0 0 -1 0
+0]N /FBB[0 0 0 0]N /nn 0 N /IE 0 N /ctr 0 N /df-tail{/nn 8 dict N nn
+begin /FontType 3 N /FontMatrix fntrx N /FontBBox FBB N string /base X
+array /BitMaps X /BuildChar{CharBuilder}N /Encoding IE N end dup{/foo
+setfont}2 array copy cvx N load 0 nn put /ctr 0 N[}B /df{/sf 1 N /fntrx
+FMat N df-tail}B /dfs{div /sf X /fntrx[sf 0 0 sf neg 0 0]N df-tail}B /E{
+pop nn dup definefont setfont}B /ch-width{ch-data dup length 5 sub get}
+B /ch-height{ch-data dup length 4 sub get}B /ch-xoff{128 ch-data dup
+length 3 sub get sub}B /ch-yoff{ch-data dup length 2 sub get 127 sub}B
+/ch-dx{ch-data dup length 1 sub get}B /ch-image{ch-data dup type
+/stringtype ne{ctr get /ctr ctr 1 add N}if}B /id 0 N /rw 0 N /rc 0 N /gp
+0 N /cp 0 N /G 0 N /sf 0 N /CharBuilder{save 3 1 roll S dup /base get 2
+index get S /BitMaps get S get /ch-data X pop /ctr 0 N ch-dx 0 ch-xoff
+ch-yoff ch-height sub ch-xoff ch-width add ch-yoff setcachedevice
+ch-width ch-height true[1 0 0 -1 -.1 ch-xoff sub ch-yoff .1 add]{
+ch-image}imagemask restore}B /D{/cc X dup type /stringtype ne{]}if nn
+/base get cc ctr put nn /BitMaps get S ctr S sf 1 ne{dup dup length 1
+sub dup 2 index S get sf div put}if put /ctr ctr 1 add N}B /I{cc 1 add D
+}B /bop{userdict /bop-hook known{bop-hook}if /SI save N @rigin 0 0
+moveto /V matrix currentmatrix dup 1 get dup mul exch 0 get dup mul add
+.99 lt{/QV}{/RV}ifelse load def pop pop}N /eop{SI restore showpage
+userdict /eop-hook known{eop-hook}if}N /@start{userdict /start-hook
+known{start-hook}if pop /VResolution X /Resolution X 1000 div /DVImag X
+/IE 256 array N 0 1 255{IE S 1 string dup 0 3 index put cvn put}for
+65781.76 div /vsize X 65781.76 div /hsize X}N /p{show}N /RMat[1 0 0 -1 0
+0]N /BDot 260 string N /rulex 0 N /ruley 0 N /v{/ruley X /rulex X V}B /V
+{}B /RV statusdict begin /product where{pop product dup length 7 ge{0 7
+getinterval dup(Display)eq exch 0 4 getinterval(NeXT)eq or}{pop false}
+ifelse}{false}ifelse end{{gsave TR -.1 -.1 TR 1 1 scale rulex ruley
+false RMat{BDot}imagemask grestore}}{{gsave TR -.1 -.1 TR rulex ruley
+scale 1 1 false RMat{BDot}imagemask grestore}}ifelse B /QV{gsave
+transform round exch round exch itransform moveto rulex 0 rlineto 0
+ruley neg rlineto rulex neg 0 rlineto fill grestore}B /a{moveto}B /delta
+0 N /tail{dup /delta X 0 rmoveto}B /M{S p delta add tail}B /b{S p tail}
+B /c{-4 M}B /d{-3 M}B /e{-2 M}B /f{-1 M}B /g{0 M}B /h{1 M}B /i{2 M}B /j{
+3 M}B /k{4 M}B /w{0 rmoveto}B /l{p -4 w}B /m{p -3 w}B /n{p -2 w}B /o{p
+-1 w}B /q{p 1 w}B /r{p 2 w}B /s{p 3 w}B /t{p 4 w}B /x{0 S rmoveto}B /y{
+3 2 roll p a}B /bos{/SS save N}B /eos{SS restore}B end
+%%EndProcSet
+TeXDict begin 40258431 52099146 1000 300 300 () @start
+/Fa 3 103 df<70F8F8F87005057C840D>58 D<0000FE0200078186001C004C0038003C
+0060003C00C0001C01C0001803800018070000180F0000181E0000101E0000103C000000
+3C00000078000000780000007800000078000000F0000000F0000000F0000000F0000000
+F00000807000008070000080700001003800010038000200180004000C00180006002000
+0381C00000FE00001F217E9F21>67 D<00007C0000CE00019E00039E00030C0007000007
+00000700000700000E00000E00000E0000FFF0000E00000E00001C00001C00001C00001C
+00001C0000380000380000380000380000380000700000700000700000700000700000E0
+0000E00000E00000E00000C00001C000318000798000F300006200003C000017297E9F16
+>102 D E /Fb 2 54 df<00300030007000F001F0017002700470087018701070207040
+70C070FFFE0070007000700070007003FE0F157F9412>52 D<20303FE03FC02400200020
+00200020002F8030E020700030003800384038E038E0388030406020C01F000D157E9412
+>I E /Fc 1 4 df<020002000200C218F2783AE00F800F803AE0F278C218020002000200
+0D0E7E8E12>3 D E /Fd 7 107 df<FFFFFFC0FFFFFFC01A027C8B23>0
+D<03C00FF01FF83FFC7FFE7FFEFFFFFFFFFFFFFFFFFFFFFFFF7FFE7FFE3FFC1FF80FF003
+C010127D9317>15 D<000000040000000002000000000200000000010000000000800000
+0000400000000020FFFFFFFFFCFFFFFFFFFC000000002000000000400000000080000000
+010000000002000000000200000000040026107D922D>33 D<0000020000000003000000
+000300000000018000000000C000000000C00000000060007FFFFFF000FFFFFFFC000000
+000E00000000038000000001F0000000007C00000000F000000003C00000000700000000
+0C00FFFFFFF8007FFFFFF0000000006000000000C0000000018000000001800000000300
+0000000300000000020000261A7D972D>41 D<004000C001800180018003000300030006
+00060006000C000C00180018001800300030003000600060006000C000C0006000600060
+003000300030001800180018000C000C0006000600060003000300030001800180018000
+C000400A2E7CA112>104 D<C000C0006000600060003000300030001800180018000C00
+0C0006000600060003000300030001800180018000C000C0018001800180030003000300
+0600060006000C000C00180018001800300030003000600060006000C000C0000A2E7DA1
+12>I<C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0
+C0C0C0C0C0C0C0C0C0C0C0C0022D7BA10D>I E /Fe 41 123 df<70F8F8F8F8F8F8F8F8
+F8F8F8F8F8F8F8F870000000000070F8F8F870051C779B18>33 D<4010E038F078E038E0
+38E038E038E038E038E038E038E038E03860300D0E7B9C18>I<387C7C7E3E0E0E0E1C1C
+38F8F0C0070E789B18>39 D<007000F001E003C007800F001E001C003800380070007000
+70007000E000E000E000E000E000E000E000E0007000700070007000380038001C001E00
+0F00078003C001F000F000700C24799F18>I<6000F00078003C001E000F000780038001
+C001C000E000E000E000E00070007000700070007000700070007000E000E000E000E001
+C001C0038007800F001E003C007800F00060000C247C9F18>I<01C00001C00001C00001
+C000C1C180F1C780F9CF807FFF001FFC0007F00007F0001FFC007FFF00F9CF80F1C780C1
+C18001C00001C00001C00001C00011147D9718>I<00600000F00000F00000F00000F000
+00F00000F00000F0007FFFC0FFFFE0FFFFE07FFFC000F00000F00000F00000F00000F000
+00F00000F00000600013147E9718>I<1C3E7E7F3F1F070E1E7CF860080C788518>I<7FFF
+00FFFF80FFFF807FFF0011047D8F18>I<3078FCFC78300606778518>I<01800380038007
+800F803F80FF80FB80438003800380038003800380038003800380038003800380038003
+800380038003807FFCFFFE7FFC0F1C7B9B18>49 D<03F0000FFE003FFF007C0F807003C0
+E001C0F000E0F000E06000E00000E00000E00001C00001C00003C0000780000F00001E00
+003C0000780000F00001E00007C0000F80001E00E03C00E07FFFE0FFFFE07FFFE0131C7E
+9B18>I<07F8001FFE003FFF007807807803C07801C03001C00001C00003C0000380000F
+0003FF0003FE0003FF000007800003C00001C00000E00000E00000E0F000E0F000E0F001
+C0F003C07C07803FFF001FFE0003F800131C7E9B18>I<3078FCFC783000000000000000
+003078FCFC78300614779318>58 D<600000F00000FC00007E00003F00001FC00007E000
+03F00001FC00007E00003F00001F80001F80003F00007E0001FC0003F00007E0001FC000
+3F00007E0000FC0000F0000060000011187D9918>62 D<0FF0003FFC007FFF00700F00F0
+0380F00380600780000F00003E00007C0001F00001E00003C00003C00003C00003C00003
+C00003800000000000000000000000000000000003800007C00007C00007C00003800011
+1C7D9B18>I<1FE0003FF8007FFC00781E00300E0000070000070000FF0007FF001FFF00
+7F0700780700E00700E00700E00700F00F00781F003FFFF01FFBF007E1F014147D9318>
+97 D<7E0000FE00007E00000E00000E00000E00000E00000E00000E3E000EFF800FFFC0
+0FC1E00F80E00F00700E00700E00380E00380E00380E00380E00380E00380F00700F0070
+0F80E00FC1E00FFFC00EFF80063E00151C809B18>I<01FE0007FF001FFF803E07803803
+00700000700000E00000E00000E00000E00000E00000E000007000007001C03801C03E03
+C01FFF8007FF0001FC0012147D9318>I<001F80003F80001F8000038000038000038000
+038000038003E3800FFB801FFF803C1F80380F80700780700380E00380E00380E00380E0
+0380E00380E00380700780700780380F803C1F801FFFF00FFBF803E3F0151C7E9B18>I<
+01F00007FC001FFE003E0F00380780700380700380E001C0E001C0FFFFC0FFFFC0FFFFC0
+E000007000007001C03801C03E03C01FFF8007FF0001FC0012147D9318>I<001F80007F
+C000FFE000E1E001C0C001C00001C00001C0007FFFC0FFFFC0FFFFC001C00001C00001C0
+0001C00001C00001C00001C00001C00001C00001C00001C00001C00001C00001C0007FFF
+007FFF007FFF00131C7F9B18>I<01E1F007FFF80FFFF81E1E301C0E0038070038070038
+07003807003807001C0E001E1E001FFC001FF80039E0003800001C00001FFE001FFFC03F
+FFE07801F0700070E00038E00038E00038E000387800F07E03F01FFFC00FFF8001FC0015
+1F7F9318>I<7E0000FE00007E00000E00000E00000E00000E00000E00000E3E000EFF80
+0FFFC00FC1C00F80E00F00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E0
+0E00E00E00E00E00E07FC3FCFFE7FE7FC3FC171C809B18>I<03800007C00007C00007C0
+000380000000000000000000000000007FC000FFC0007FC00001C00001C00001C00001C0
+0001C00001C00001C00001C00001C00001C00001C00001C00001C00001C000FFFF00FFFF
+80FFFF00111D7C9C18>I<FE0000FE0000FE00000E00000E00000E00000E00000E00000E
+3FF00E7FF00E3FF00E07800E0F000E1E000E3C000E78000EF0000FF8000FFC000F9C000F
+0E000E0F000E07000E03800E03C0FFC7F8FFC7F8FFC7F8151C7F9B18>107
+D<7FE000FFE0007FE00000E00000E00000E00000E00000E00000E00000E00000E00000E0
+0000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E0
+0000E0007FFFC0FFFFE07FFFC0131C7E9B18>I<7CE0E000FFFBF8007FFFF8001F1F1C00
+1E1E1C001E1E1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C001C1C1C00
+1C1C1C001C1C1C001C1C1C001C1C1C007F1F1F00FFBFBF807F1F1F001914819318>I<7E
+3E00FEFF807FFFC00FC1C00F80E00F00E00E00E00E00E00E00E00E00E00E00E00E00E00E
+00E00E00E00E00E00E00E00E00E07FC3FCFFE7FE7FC3FC1714809318>I<01F0000FFE00
+1FFF003E0F803803807001C07001C0E000E0E000E0E000E0E000E0E000E0F001E07001C0
+7803C03C07803E0F801FFF000FFE0001F00013147E9318>I<7E3E00FEFF807FFFC00FC1
+E00F80E00F00700E00700E00380E00380E00380E00380E00380E00380F00700F00700F80
+E00FC1E00FFFC00EFF800E3E000E00000E00000E00000E00000E00000E00000E00007FC0
+00FFE0007FC000151E809318>I<01E38007FB801FFF803E1F80380F80700780700780E0
+0380E00380E00380E00380E00380E00380700780700780380F803C1F801FFF800FFB8003
+E380000380000380000380000380000380000380000380003FF8003FF8003FF8151E7E93
+18>I<7F87E0FF9FF07FBFF803F87803F03003E00003C00003C000038000038000038000
+0380000380000380000380000380000380007FFE00FFFF007FFE0015147F9318>I<07F7
+003FFF007FFF00780F00E00700E00700E007007C00007FE0001FFC0003FE00001F006007
+80E00380E00380F00380F80F00FFFF00FFFC00E7F00011147D9318>I<01800003800003
+80000380000380007FFFC0FFFFC0FFFFC003800003800003800003800003800003800003
+80000380000380000380400380E00380E00380E001C1C001FFC000FF80003E0013197F98
+18>I<7E07E0FE0FE07E07E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E00E0
+0E00E00E00E00E00E00E00E00E01E00F03E007FFFC03FFFE01FCFC1714809318>I<7F8F
+F0FF8FF87F8FF01E03C00E03800E03800E0380070700070700070700038E00038E00038E
+00038E0001DC0001DC0001DC0000F80000F80000700015147F9318>I<FF8FF8FF8FF8FF
+8FF83800E03800E03800E01C01C01C01C01C71C01CF9C01CF9C01CD9C01CD9C00DDD800D
+DD800DDD800D8D800F8F800F8F8007070015147F9318>I<7F8FF07F9FF07F8FF0070700
+078E00039E0001DC0001F80000F80000700000F00000F80001DC00039E00038E00070700
+0F07807F8FF0FF8FF87F8FF015147F9318>I<7F8FF0FF8FF87F8FF00E01C00E03800E03
+80070380070700070700038700038600038E0001CE0001CE0000CC0000CC0000DC000078
+0000780000780000700000700000700000F00000E00079E0007BC0007F80003F00001E00
+00151E7F9318>I<3FFFF07FFFF07FFFF07001E07003C0700780000F00001E00003C0000
+F80001F00003C0000780000F00701E00703C0070780070FFFFF0FFFFF0FFFFF014147F93
+18>I E /Ff 35 122 df<00003FE00000E0100001803800038078000300780007003000
+0700000007000000070000000E0000000E0000000E000000FFFFE0000E00E0001C01C000
+1C01C0001C01C0001C01C0001C0380003803800038038000380380003807000038070000
+7007000070071000700E2000700E2000700E2000E00E2000E0064000E0038000E0000000
+C0000001C0000001C000003180000079800000F3000000620000003C0000001D29829F1A
+>12 D<1C3C3C3C3C040408081020204080060E7D840E>44 D<7FF0FFE07FE00C037D8A10
+>I<70F8F8F0E005057B840E>I<00000200000006000000060000000E0000001E0000001E
+0000003F0000002F0000004F0000004F0000008F0000010F0000010F0000020F0000020F
+0000040F00000C0F0000080F0000100F0000100F0000200F80003FFF800040078000C007
+800080078001000780010007800200078002000780060007801E000F80FF807FF81D207E
+9F22>65 D<0000FE0200078186001C004C0038003C0060003C00C0001C01C00018038000
+18070000180F0000181E0000101E0000103C0000003C0000007800000078000000780000
+0078000000F0000000F0000000F0000000F0000000F00000807000008070000080700001
+003800010038000200180004000C001800060020000381C00000FE00001F217A9F21>67
+D<01FFFFFC001E0038001E0018001E0008001E0008003C0008003C0008003C0008003C00
+080078001000780800007808000078080000F0100000F0300000FFF00000F0300001E020
+0001E0200001E0200001E0200003C0000003C0000003C0000003C0000007800000078000
+0007800000078000000F800000FFF800001E1F7D9E1E>70 D<01FFF0001F00001E00001E
+00001E00003C00003C00003C00003C0000780000780000780000780000F00000F00000F0
+0000F00001E00001E00001E00001E00003C00003C00003C00003C0000780000780000780
+000780000F8000FFF800141F7D9E12>73 D<01FFF800001F0000001E0000001E0000001E
+0000003C0000003C0000003C0000003C00000078000000780000007800000078000000F0
+000000F0000000F0000000F0000001E0000001E0000001E0000001E0008003C0010003C0
+010003C0030003C00200078006000780060007800C0007801C000F007800FFFFF800191F
+7D9E1D>76 D<01FE00007FC0001E0000FC00001E0000F800001700017800001700017800
+00270002F00000270004F00000270004F00000270008F00000470009E00000470011E000
+00470021E00000470021E00000870043C00000838043C00000838083C00000838083C000
+0103810780000103820780000103820780000103840780000203840F00000203880F0000
+0203900F00000203900F00000401E01E00000401E01E00000401C01E00000C01801E0000
+1C01803E0000FF8103FFC0002A1F7D9E29>I<01FFFF80001E00E0001E0070001E003800
+1E003C003C003C003C003C003C003C003C003C0078007800780078007800F0007800E000
+F003C000F00F0000FFFC0000F0000001E0000001E0000001E0000001E0000003C0000003
+C0000003C0000003C00000078000000780000007800000078000000F800000FFF000001E
+1F7D9E1F>80 D<01FFFF00001E03C0001E00E0001E0070001E0078003C0078003C007800
+3C0078003C0078007800F0007800F0007801E0007801C000F0070000F01E0000FFF00000
+F0380001E01C0001E01E0001E00E0001E00F0003C01E0003C01E0003C01E0003C01E0007
+803C0007803C0807803C0807803C100F801C10FFF00C20000007C01D207D9E21>82
+D<0007E040001C18C0003005800060038000C0038001C001800180010003800100038001
+00038001000380000003C0000003C0000003F8000001FF800001FFE000007FF000001FF0
+000001F80000007800000078000000380000003800200038002000380020003000600070
+00600060006000E0007000C000E8038000C606000081F800001A217D9F1A>I<00F18003
+89C00707800E03801C03803C0380380700780700780700780700F00E00F00E00F00E00F0
+0E20F01C40F01C40703C40705C40308C800F070013147C9317>97
+D<07803F8007000700070007000E000E000E000E001C001C001CF01D0C3A0E3C0E380F38
+0F700F700F700F700FE01EE01EE01EE01CE03CE038607060E031C01F0010207B9F15>I<
+007E0001C1000300800E07801E07801C07003C0200780000780000780000F00000F00000
+F00000F00000F0000070010070020030040018380007C00011147C9315>I<0000780003
+F80000700000700000700000700000E00000E00000E00000E00001C00001C000F1C00389
+C00707800E03801C03803C0380380700780700780700780700F00E00F00E00F00E00F00E
+20F01C40F01C40703C40705C40308C800F070015207C9F17>I<007C01C207010E011C01
+3C013802780C7BF07C00F000F000F000F0007000700170023804183807C010147C9315>
+I<00007800019C00033C00033C000718000700000700000E00000E00000E00000E00000E
+0001FFE0001C00001C00001C00001C000038000038000038000038000038000070000070
+0000700000700000700000700000E00000E00000E00000E00000C00001C00001C0000180
+003180007B0000F300006600003C00001629829F0E>I<003C6000E27001C1E00380E007
+00E00F00E00E01C01E01C01E01C01E01C03C03803C03803C03803C03803C07003C07001C
+0F001C17000C2E0003CE00000E00000E00001C00001C00301C00783800F0700060E0003F
+8000141D7E9315>I<01E0000FE00001C00001C00001C00001C000038000038000038000
+038000070000070000071E000763000E81800F01C00E01C00E01C01C03801C03801C0380
+1C0380380700380700380700380E10700E20700C20701C20700C40E00CC060070014207D
+9F17>I<00C001E001E001C000000000000000000000000000000E003300230043804300
+470087000E000E000E001C001C001C003840388030807080310033001C000B1F7C9E0E>
+I<01E0000FE00001C00001C00001C00001C0000380000380000380000380000700000700
+000703C00704200E08E00E11E00E21E00E40C01C80001D00001E00001FC00038E0003870
+00387000383840707080707080707080703100E03100601E0013207D9F15>107
+D<03C01FC0038003800380038007000700070007000E000E000E000E001C001C001C001C
+0038003800380038007000700070007100E200E200E200E200640038000A207C9F0C>I<
+1C0F80F0002630C318004740640C004780680E004700700E004700700E008E00E01C000E
+00E01C000E00E01C000E00E01C001C01C038001C01C038001C01C038001C01C070803803
+8071003803806100380380E10038038062007007006600300300380021147C9325>I<1C
+0F802630C04740604780604700704700708E00E00E00E00E00E00E00E01C01C01C01C01C
+01C01C03843803883803083807083803107003303001C016147C931A>I<007C0001C300
+0301800E01C01E01C01C01E03C01E07801E07801E07801E0F003C0F003C0F003C0F00780
+F00700700F00700E0030180018700007C00013147C9317>I<01C1E002621804741C0478
+1C04701E04701E08E01E00E01E00E01E00E01E01C03C01C03C01C03C01C0380380780380
+700380E003C1C0072380071E000700000700000E00000E00000E00000E00001C00001C00
+00FFC000171D809317>I<1C1E002661004783804787804707804703008E00000E00000E
+00000E00001C00001C00001C00001C000038000038000038000038000070000030000011
+147C9313>114 D<00FC030206010C030C070C060C000F800FF007F803FC003E000E700E
+F00CF00CE008401020601F8010147D9313>I<018001C0038003800380038007000700FF
+F007000E000E000E000E001C001C001C001C003800380038003820704070407080708031
+001E000C1C7C9B0F>I<0E00C03300E02301C04381C04301C04701C08703800E03800E03
+800E03801C07001C07001C07001C07101C0E20180E20180E201C1E200C264007C3801414
+7C9318>I<0E00C1C03300E3C02301C3E04381C1E04301C0E04701C060870380400E0380
+400E0380400E0380401C0700801C0700801C0700801C0701001C0701001C0602001C0F02
+000C0F04000E13080003E1F0001B147C931E>119 D<0383800CC4401068E01071E02071
+E02070C040E00000E00000E00000E00001C00001C00001C00001C040638080F38080F381
+00E5810084C60078780013147D9315>I<0E00C03300E02301C04381C04301C04701C087
+03800E03800E03800E03801C07001C07001C07001C07001C0E00180E00180E001C1E000C
+3C0007DC00001C00001C00003800F03800F07000E06000C0C0004380003E0000131D7C93
+16>I E /Fg 27 118 df<000FF000007FFC0001F80E0003E01F0007C03F000F803F000F
+803F000F801E000F800C000F8000000F8000000F8000000F800000FFFFFF00FFFFFF000F
+801F000F801F000F801F000F801F000F801F000F801F000F801F000F801F000F801F000F
+801F000F801F000F801F000F801F000F801F000F801F000F801F000F801F000F801F007F
+F0FFE07FF0FFE01B237FA21F>12 D<FFFCFFFCFFFCFFFC0E047F8C13>45
+D<0003FE0080001FFF818000FF01E38001F8003F8003E0001F8007C0000F800F80000780
+1F800007803F000003803F000003807F000001807E000001807E00000180FE00000000FE
+00000000FE00000000FE00000000FE00000000FE00000000FE00000000FE000000007E00
+0000007E000001807F000001803F000001803F000003801F800003000F8000030007C000
+060003F0000C0001F800380000FF00F000001FFFC0000003FE000021227DA128>67
+D<FFFFFF8000FFFFFFF00007F003FC0007F0007E0007F0003F0007F0001F8007F0000FC0
+07F00007E007F00007E007F00007F007F00003F007F00003F007F00003F007F00003F807
+F00003F807F00003F807F00003F807F00003F807F00003F807F00003F807F00003F807F0
+0003F807F00003F007F00003F007F00003F007F00007E007F00007E007F0000FC007F000
+1F8007F0003F0007F0007E0007F003FC00FFFFFFF000FFFFFF800025227EA12B>I<FFFF
+83FFFEFFFF83FFFE07F0001FC007F0001FC007F0001FC007F0001FC007F0001FC007F000
+1FC007F0001FC007F0001FC007F0001FC007F0001FC007F0001FC007F0001FC007F0001F
+C007FFFFFFC007FFFFFFC007F0001FC007F0001FC007F0001FC007F0001FC007F0001FC0
+07F0001FC007F0001FC007F0001FC007F0001FC007F0001FC007F0001FC007F0001FC007
+F0001FC007F0001FC007F0001FC0FFFF83FFFEFFFF83FFFE27227EA12C>72
+D<FFFFE0FFFFE003F80003F80003F80003F80003F80003F80003F80003F80003F80003F8
+0003F80003F80003F80003F80003F80003F80003F80003F80003F80003F80003F80003F8
+0003F80003F80003F80003F80003F80003F80003F80003F800FFFFE0FFFFE013227FA115
+>I<FFF000000FFFFFF800001FFF07F800001FE006FC000037E006FC000037E006FC0000
+37E0067E000067E0067E000067E0063F0000C7E0063F0000C7E0061F800187E0061F8001
+87E0060FC00307E0060FC00307E0060FC00307E00607E00607E00607E00607E00603F00C
+07E00603F00C07E00601F81807E00601F81807E00601F81807E00600FC3007E00600FC30
+07E006007E6007E006007E6007E006003FC007E006003FC007E006001F8007E006001F80
+07E006001F8007E006000F0007E0FFF00F00FFFFFFF00600FFFF30227EA135>77
+D<01FC0407FF8C1F03FC3C007C7C003C78001C78001CF8000CF8000CFC000CFC0000FF00
+00FFE0007FFF007FFFC03FFFF01FFFF80FFFFC03FFFE003FFE0003FF00007F00003F0000
+3FC0001FC0001FC0001FE0001EE0001EF0003CFC003CFF00F8C7FFE080FF8018227DA11F
+>83 D<7FFFFFFF807FFFFFFF807E03F80F807803F807807003F803806003F80180E003F8
+01C0E003F801C0C003F800C0C003F800C0C003F800C0C003F800C00003F800000003F800
+000003F800000003F800000003F800000003F800000003F800000003F800000003F80000
+0003F800000003F800000003F800000003F800000003F800000003F800000003F8000000
+03F800000003F800000003F800000003F8000003FFFFF80003FFFFF80022227EA127>I<
+07FC001FFF803F07C03F03E03F01E03F01F01E01F00001F00001F0003FF003FDF01FC1F0
+3F01F07E01F0FC01F0FC01F0FC01F0FC01F07E02F07E0CF81FF87F07E03F18167E951B>
+97 D<00FF8007FFE00F83F01F03F03E03F07E03F07C01E07C0000FC0000FC0000FC0000
+FC0000FC0000FC00007C00007E00007E00003E00301F00600FC0E007FF8000FE0014167E
+9519>99 D<0001FE000001FE0000003E0000003E0000003E0000003E0000003E0000003E
+0000003E0000003E0000003E0000003E0000003E0001FC3E0007FFBE000F81FE001F007E
+003E003E007E003E007C003E00FC003E00FC003E00FC003E00FC003E00FC003E00FC003E
+00FC003E00FC003E007C003E007C003E003E007E001E00FE000F83BE0007FF3FC001FC3F
+C01A237EA21F>I<00FE0007FF800F87C01E01E03E01F07C00F07C00F8FC00F8FC00F8FF
+FFF8FFFFF8FC0000FC0000FC00007C00007C00007E00003E00181F00300FC07003FFC000
+FF0015167E951A>I<003F8000FFC001E3E003C7E007C7E00F87E00F83C00F80000F8000
+0F80000F80000F80000F8000FFFC00FFFC000F80000F80000F80000F80000F80000F8000
+0F80000F80000F80000F80000F80000F80000F80000F80000F80000F80000F80000F8000
+7FF8007FF80013237FA211>I<03FC1E0FFF7F1F0F8F3E07CF3C03C07C03E07C03E07C03
+E07C03E07C03E03C03C03E07C01F0F801FFF0013FC003000003000003800003FFF801FFF
+F00FFFF81FFFFC3800FC70003EF0001EF0001EF0001EF0001E78003C7C007C3F01F80FFF
+E001FF0018217E951C>I<FF000000FF0000001F0000001F0000001F0000001F0000001F
+0000001F0000001F0000001F0000001F0000001F0000001F0000001F07E0001F1FF8001F
+307C001F403C001F803E001F803E001F003E001F003E001F003E001F003E001F003E001F
+003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E00FF
+E1FFC0FFE1FFC01A237EA21F>I<1C003E007F007F007F003E001C000000000000000000
+000000000000FF00FF001F001F001F001F001F001F001F001F001F001F001F001F001F00
+1F001F001F001F001F00FFE0FFE00B247EA310>I<FF000000FF0000001F0000001F0000
+001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000001F0000
+001F00FF801F00FF801F0038001F0060001F01C0001F0380001F0700001F0E00001F1C00
+001F7E00001FFF00001FCF00001F0F80001F07C0001F03E0001F01E0001F01F0001F00F8
+001F007C001F003C00FFE0FFC0FFE0FFC01A237EA21E>107 D<FF00FF001F001F001F00
+1F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F00
+1F001F001F001F001F001F001F001F001F001F00FFE0FFE00B237EA210>I<FF07F007F0
+00FF1FFC1FFC001F303E303E001F403E403E001F801F801F001F801F801F001F001F001F
+001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F
+001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F001F
+001F001F001F00FFE0FFE0FFE0FFE0FFE0FFE02B167E9530>I<FF07E000FF1FF8001F30
+7C001F403C001F803E001F803E001F003E001F003E001F003E001F003E001F003E001F00
+3E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E00FFE1
+FFC0FFE1FFC01A167E951F>I<00FE0007FFC00F83E01E00F03E00F87C007C7C007C7C00
+7CFC007EFC007EFC007EFC007EFC007EFC007EFC007E7C007C7C007C3E00F81F01F00F83
+E007FFC000FE0017167E951C>I<FF0FE000FF3FF8001FF07C001F803E001F001F001F00
+1F801F001F801F000FC01F000FC01F000FC01F000FC01F000FC01F000FC01F000FC01F00
+0FC01F001F801F001F801F803F001FC03E001FE0FC001F3FF8001F0FC0001F0000001F00
+00001F0000001F0000001F0000001F0000001F0000001F000000FFE00000FFE000001A20
+7E951F>I<FE1F00FE3FC01E67E01EC7E01E87E01E87E01F83C01F00001F00001F00001F
+00001F00001F00001F00001F00001F00001F00001F00001F00001F0000FFF000FFF00013
+167E9517>114 D<0FF3003FFF00781F00600700E00300E00300F00300FC00007FE0007F
+F8003FFE000FFF0001FF00000F80C00780C00380E00380E00380F00700FC0E00EFFC00C7
+F00011167E9516>I<0180000180000180000180000380000380000780000780000F8000
+3F8000FFFF00FFFF000F80000F80000F80000F80000F80000F80000F80000F80000F8000
+0F80000F80000F81800F81800F81800F81800F81800F830007C30003FE0000F80011207F
+9F16>I<FF01FE00FF01FE001F003E001F003E001F003E001F003E001F003E001F003E00
+1F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E001F003E00
+1F007E001F00FE000F81BE0007FF3FC001FC3FC01A167E951F>I
+E /Fh 81 125 df<001F83E000F06E3001C078780380F8780300F0300700700007007000
+0700700007007000070070000700700007007000FFFFFF80070070000700700007007000
+070070000700700007007000070070000700700007007000070070000700700007007000
+0700700007007000070070000700700007007000070070007FE3FF001D20809F1B>11
+D<003F0000E0C001C0C00381E00701E00701E00700000700000700000700000700000700
+00FFFFE00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700
+E00700E00700E00700E00700E00700E00700E00700E07FC3FE1720809F19>I<003FE000
+E0E001C1E00381E00700E00700E00700E00700E00700E00700E00700E00700E0FFFFE007
+00E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E00700E007
+00E00700E00700E00700E00700E00700E07FE7FE1720809F19>I<001F81F80000F04F04
+0001C07C06000380F80F000300F00F000700F00F00070070000007007000000700700000
+070070000007007000000700700000FFFFFFFF0007007007000700700700070070070007
+007007000700700700070070070007007007000700700700070070070007007007000700
+700700070070070007007007000700700700070070070007007007000700700700070070
+07007FE3FE3FF02420809F26>I<7038F87CFC7EFC7E743A040204020402080408041008
+1008201040200F0E7E9F17>34 D<70F8FCFC74040404080810102040060E7C9F0D>39
+D<0020004000800100020006000C000C00180018003000300030007000600060006000E0
+00E000E000E000E000E000E000E000E000E000E000E00060006000600070003000300030
+00180018000C000C000600020001000080004000200B2E7DA112>I<8000400020001000
+08000C00060006000300030001800180018001C000C000C000C000E000E000E000E000E0
+00E000E000E000E000E000E000E000C000C000C001C00180018001800300030006000600
+0C00080010002000400080000B2E7DA112>I<70F8FCFC74040404080810102040060E7C
+840D>44 D<FFC0FFC00A027F8A0F>I<70F8F8F87005057C840D>I<000100030003000600
+060006000C000C000C00180018001800300030003000600060006000C000C000C0018001
+8001800300030003000600060006000C000C000C00180018001800300030003000600060
+006000C000C000C000102D7DA117>I<03F0000E1C001C0E001806003807007003807003
+80700380700380F003C0F003C0F003C0F003C0F003C0F003C0F003C0F003C0F003C0F003
+C0F003C0F003C0F003C07003807003807003807807803807001806001C0E000E1C0003F0
+00121F7E9D17>I<018003800F80F3800380038003800380038003800380038003800380
+0380038003800380038003800380038003800380038003800380038007C0FFFE0F1E7C9D
+17>I<03F0000C1C00100E00200700400780800780F007C0F803C0F803C0F803C02007C0
+0007C0000780000780000F00000E00001C0000380000700000600000C000018000030000
+0600400C00401800401000803FFF807FFF80FFFF80121E7E9D17>I<03F0000C1C00100E
+00200F00780F80780780780780380F80000F80000F00000F00000E00001C0000380003F0
+00003C00000E00000F000007800007800007C02007C0F807C0F807C0F807C0F007804007
+80400F00200E001C3C0003F000121F7E9D17>I<000600000600000E00000E00001E0000
+2E00002E00004E00008E00008E00010E00020E00020E00040E00080E00080E00100E0020
+0E00200E00400E00C00E00FFFFF0000E00000E00000E00000E00000E00000E00000E0000
+FFE0141E7F9D17>I<1803001FFE001FFC001FF8001FE000100000100000100000100000
+10000010000011F000161C00180E001007001007800003800003800003C00003C00003C0
+7003C0F003C0F003C0E00380400380400700200600100E000C380003E000121F7E9D17>
+I<007C000182000701000E03800C07801C0780380300380000780000700000700000F1F0
+00F21C00F40600F80700F80380F80380F003C0F003C0F003C0F003C0F003C07003C07003
+C07003803803803807001807000C0E00061C0001F000121F7E9D17>I<4000007FFFC07F
+FF807FFF8040010080020080020080040000080000080000100000200000200000400000
+400000C00000C00001C00001800003800003800003800003800007800007800007800007
+8000078000078000078000030000121F7D9D17>I<03F0000C0C00100600300300200180
+6001806001806001807001807803003E03003F06001FC8000FF00003F80007FC000C7E00
+103F00300F806003804001C0C001C0C000C0C000C0C000C0C00080600180200100100200
+0C0C0003F000121F7E9D17>I<03F0000E18001C0C00380600380700700700700380F003
+80F00380F003C0F003C0F003C0F003C0F003C07007C07007C03807C0180BC00E13C003E3
+C0000380000380000380000700300700780600780E00700C002018001070000FC000121F
+7E9D17>I<70F8F8F8700000000000000000000070F8F8F87005147C930D>I<70F8F8F870
+0000000000000000000070F0F8F878080808101010202040051D7C930D>I<7FFFFFE0FF
+FFFFF00000000000000000000000000000000000000000000000000000000000000000FF
+FFFFF07FFFFFE01C0C7D9023>61 D<000100000003800000038000000380000007C00000
+07C0000007C0000009E0000009E0000009E0000010F0000010F0000010F0000020780000
+2078000020780000403C0000403C0000403C0000801E0000801E0000FFFE0001000F0001
+000F0001000F00020007800200078002000780040003C00E0003C01F0007E0FFC03FFE1F
+207F9F22>65 D<FFFFE0000F80380007801E0007801F0007800F0007800F8007800F8007
+800F8007800F8007800F8007800F0007801F0007801E0007803C0007FFF00007803C0007
+801E0007800F0007800F8007800780078007C0078007C0078007C0078007C0078007C007
+80078007800F8007800F0007801F000F803C00FFFFF0001A1F7E9E20>I<000FC0400070
+30C001C009C0038005C0070003C00E0001C01E0000C01C0000C03C0000C07C0000407C00
+004078000040F8000000F8000000F8000000F8000000F8000000F8000000F8000000F800
+0000F8000000780000007C0000407C0000403C0000401C0000401E0000800E0000800700
+01000380020001C0040000703800000FC0001A217D9F21>I<FFFFE0000F803C0007801E
+000780070007800380078003C0078001E0078001E0078001F0078000F0078000F0078000
+F8078000F8078000F8078000F8078000F8078000F8078000F8078000F8078000F8078000
+F0078000F0078000F0078001E0078001E0078003C0078003800780070007800E000F803C
+00FFFFE0001D1F7E9E23>I<FFFFFF000F800F0007800300078003000780010007800180
+078000800780008007800080078080800780800007808000078080000781800007FF8000
+078180000780800007808000078080000780800007800020078000200780002007800040
+0780004007800040078000C0078000C0078001800F800F80FFFFFF801B1F7E9E1F>I<FF
+FFFF000F800F000780030007800300078001000780018007800080078000800780008007
+800080078080000780800007808000078080000781800007FF8000078180000780800007
+808000078080000780800007800000078000000780000007800000078000000780000007
+800000078000000FC00000FFFE0000191F7E9E1E>I<000FE0200078186000E004E00380
+02E0070001E00F0000E01E0000601E0000603C0000603C0000207C00002078000020F800
+0000F8000000F8000000F8000000F8000000F8000000F8000000F8007FFCF80003E07800
+01E07C0001E03C0001E03C0001E01E0001E01E0001E00F0001E0070001E0038002E000E0
+046000781820000FE0001E217D9F24>I<FFF8FFF80F800F8007800F0007800F0007800F
+0007800F0007800F0007800F0007800F0007800F0007800F0007800F0007800F0007800F
+0007FFFF0007800F0007800F0007800F0007800F0007800F0007800F0007800F0007800F
+0007800F0007800F0007800F0007800F0007800F0007800F000F800F80FFF8FFF81D1F7E
+9E22>I<FFFC0FC007800780078007800780078007800780078007800780078007800780
+07800780078007800780078007800780078007800780078007800FC0FFFC0E1F7F9E10>
+I<0FFFC0007C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C
+00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C00003C00203C
+00F83C00F83C00F83C00F0380040780040700030E0000F800012207E9E17>I<FFFC0FFC
+0FC003E00780018007800100078002000780040007800800078010000780200007804000
+07808000078100000783000007878000078F80000793C0000791E00007A1E00007C0F000
+0780F0000780780007803C0007803C0007801E0007801E0007800F000780078007800780
+078007C00FC007E0FFFC3FFC1E1F7E9E23>I<FFFE000FC0000780000780000780000780
+000780000780000780000780000780000780000780000780000780000780000780000780
+0007800007800007800207800207800207800207800607800407800407800C07801C0F80
+7CFFFFFC171F7E9E1C>I<FF80001FF80F80001F800780001F0005C0002F0005C0002F00
+05C0002F0004E0004F0004E0004F000470008F000470008F000470008F000438010F0004
+38010F000438010F00041C020F00041C020F00041C020F00040E040F00040E040F00040E
+040F000407080F000407080F000407080F000403900F000403900F000401E00F000401E0
+0F000401E00F000E00C00F001F00C01F80FFE0C1FFF8251F7E9E2A>I<FF803FF807C007
+C007C0038005E0010005E0010004F001000478010004780100043C0100043C0100041E01
+00040F0100040F010004078100040781000403C1000401E1000401E1000400F1000400F1
+000400790004003D0004003D0004001F0004001F0004000F0004000700040007000E0003
+001F000300FFE001001D1F7E9E22>I<001F800000F0F00001C0380007801E000F000F00
+0E0007001E0007803C0003C03C0003C07C0003E0780001E0780001E0F80001F0F80001F0
+F80001F0F80001F0F80001F0F80001F0F80001F0F80001F0F80001F0780001E07C0003E0
+7C0003E03C0003C03C0003C01E0007800E0007000F000F0007801E0001C0380000F0F000
+001F80001C217D9F23>I<FFFFE0000F80780007801C0007801E0007800F0007800F8007
+800F8007800F8007800F8007800F8007800F8007800F0007801E0007801C000780780007
+FFE000078000000780000007800000078000000780000007800000078000000780000007
+800000078000000780000007800000078000000FC00000FFFC0000191F7E9E1F>I<001F
+800000F0F00001C0380007801E000F000F000E0007001E0007803C0003C03C0003C07C00
+03E07C0003E0780001E0F80001F0F80001F0F80001F0F80001F0F80001F0F80001F0F800
+01F0F80001F0F80001F0780001E0780001E07C0003E03C0003C03C0F03C01E1087800E20
+C7000F20CF0007A0FE0001E0F80000F0F010001FF0100000701000007830000038700000
+3FF000003FE000001FE000000FC0000007801C297D9F23>I<FFFF80000F80F000078078
+0007803C0007801E0007801E0007801F0007801F0007801F0007801F0007801E0007801E
+0007803C00078078000780F00007FF80000781C0000780E0000780F00007807000078078
+00078078000780780007807C0007807C0007807C0007807C0407807E0407803E040FC01E
+08FFFC0F10000003E01E207E9E21>I<07E0800C1980100780300380600180600180E001
+80E00080E00080E00080F00000F000007800007F00003FF0001FFC000FFE0003FF00001F
+800007800003C00003C00001C08001C08001C08001C08001C0C00180C00380E00300F006
+00CE0C0081F80012217D9F19>I<7FFFFFE0780F01E0600F0060400F0020400F0020C00F
+0030800F0010800F0010800F0010800F0010000F0000000F0000000F0000000F0000000F
+0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F0000000F
+0000000F0000000F0000000F0000000F0000000F0000001F800007FFFE001C1F7E9E21>
+I<FFFC3FF80FC007C0078003800780010007800100078001000780010007800100078001
+000780010007800100078001000780010007800100078001000780010007800100078001
+00078001000780010007800100078001000780010007800100038002000380020001C002
+0001C0040000E008000070180000382000000FC0001D207E9E22>I<FFF003FE1F8000F8
+0F0000600F800060078000400780004003C0008003C0008003C0008001E0010001E00100
+01F0010000F0020000F0020000F806000078040000780400003C0800003C0800003C0800
+001E1000001E1000001F3000000F2000000F20000007C0000007C0000007C00000038000
+0003800000038000000100001F207F9E22>I<FFF07FF81FF01F800FC007C00F00078003
+800F00078001000F0007C00100078007C00200078007C00200078007C0020003C009E004
+0003C009E0040003C009E0040003E010F00C0001E010F0080001E010F0080001F0207808
+0000F02078100000F02078100000F0403C10000078403C20000078403C20000078C03E20
+00003C801E4000003C801E4000003C801E4000001F000F8000001F000F8000001F000F80
+00001E00078000000E00070000000E00070000000C000300000004000200002C207F9E2F
+>I<7FF83FF80FE00FC007C0070003C0020001E0040001F00C0000F0080000781000007C
+1000003C2000003E4000001E4000000F8000000F8000000780000003C0000007E0000005
+E0000009F0000018F8000010780000207C0000603C0000401E0000801F0001800F000100
+0780020007C0070003C01F8007E0FFE01FFE1F1F7F9E22>I<FFF003FF1F8000F80F8000
+600780004007C0004003E0008001E0008001F0010000F0030000F80200007C0400003C04
+00003E0800001E0800001F1000000FB0000007A0000007C0000003C0000003C0000003C0
+000003C0000003C0000003C0000003C0000003C0000003C0000003C0000003C0000007C0
+00007FFE00201F7F9E22>I<FEFEC0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0
+C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0C0FEFE072D7CA10D>91
+D<080410082010201040204020804080408040B85CFC7EFC7E7C3E381C0F0E7B9F17>I<
+FEFE06060606060606060606060606060606060606060606060606060606060606060606
+06060606060606FEFE072D7FA10D>I<1FE000303000781800781C00300E00000E00000E
+00000E0000FE00078E001E0E00380E00780E00F00E10F00E10F00E10F01E10781E103867
+200F83C014147E9317>97 D<0E0000FE00000E00000E00000E00000E00000E00000E0000
+0E00000E00000E00000E00000E3E000EC3800F01C00F00E00E00E00E00700E00700E0078
+0E00780E00780E00780E00780E00780E00700E00700E00E00F00E00D01C00CC300083E00
+15207F9F19>I<03F80E0C1C1E381E380C70007000F000F000F000F000F000F000700070
+00380138011C020E0C03F010147E9314>I<000380003F80000380000380000380000380
+00038000038000038000038000038000038003E380061B801C0780380380380380700380
+700380F00380F00380F00380F00380F00380F003807003807003803803803807801C0780
+0E1B8003E3F815207E9F19>I<03F0000E1C001C0E00380700380700700700700380F003
+80F00380FFFF80F00000F00000F000007000007000003800801800800C010007060001F8
+0011147F9314>I<007C00C6018F038F07060700070007000700070007000700FFF00700
+070007000700070007000700070007000700070007000700070007000700070007007FF0
+1020809F0E>I<0000E003E3300E3C301C1C30380E00780F00780F00780F00780F00780F
+00380E001C1C001E380033E0002000002000003000003000003FFE001FFF800FFFC03001
+E0600070C00030C00030C00030C000306000603000C01C038003FC00141F7F9417>I<0E
+0000FE00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E00000E
+3E000E43000E81800F01C00F01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E
+01C00E01C00E01C00E01C00E01C00E01C00E01C0FFE7FC16207F9F19>I<1C003E003E00
+3E001C000000000000000000000000000E007E000E000E000E000E000E000E000E000E00
+0E000E000E000E000E000E000E000E000E00FFC00A1F809E0C>I<00E001F001F001F000
+E0000000000000000000000000007007F000F00070007000700070007000700070007000
+700070007000700070007000700070007000700070007000706070F060F0C061803F000C
+28829E0E>I<0E0000FE00000E00000E00000E00000E00000E00000E00000E00000E0000
+0E00000E00000E0FF00E03C00E03000E02000E04000E08000E10000E30000E70000EF800
+0F38000E1C000E1E000E0E000E07000E07800E03800E03C00E03E0FFCFF815207F9F18>
+I<0E00FE000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E000E
+000E000E000E000E000E000E000E000E000E000E000E000E000E00FFE00B20809F0C>I<
+0E1F01F000FE618618000E81C81C000F00F00E000F00F00E000E00E00E000E00E00E000E
+00E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00E00E000E00
+E00E000E00E00E000E00E00E000E00E00E000E00E00E00FFE7FE7FE023147F9326>I<0E
+3E00FE43000E81800F01C00F01C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E
+01C00E01C00E01C00E01C00E01C00E01C00E01C0FFE7FC16147F9319>I<01F800070E00
+1C03803801C03801C07000E07000E0F000F0F000F0F000F0F000F0F000F0F000F07000E0
+7000E03801C03801C01C0380070E0001F80014147F9317>I<0E3E00FEC3800F01C00F00
+E00E00E00E00F00E00700E00780E00780E00780E00780E00780E00780E00700E00F00E00
+E00F01E00F01C00EC3000E3E000E00000E00000E00000E00000E00000E00000E00000E00
+00FFE000151D7F9319>I<03E0800619801C05803C0780380380780380700380F00380F0
+0380F00380F00380F00380F003807003807803803803803807801C0B800E138003E38000
+0380000380000380000380000380000380000380000380003FF8151D7E9318>I<0E78FE
+8C0F1E0F1E0F0C0E000E000E000E000E000E000E000E000E000E000E000E000E000E00FF
+E00F147F9312>I<1F9030704030C010C010C010E00078007F803FE00FF0007080388018
+8018C018C018E030D0608F800D147E9312>I<020002000200060006000E000E003E00FF
+F80E000E000E000E000E000E000E000E000E000E000E000E080E080E080E080E08061003
+1001E00D1C7F9B12>I<0E01C0FE1FC00E01C00E01C00E01C00E01C00E01C00E01C00E01
+C00E01C00E01C00E01C00E01C00E01C00E01C00E01C00E03C00603C0030DC001F1FC1614
+7F9319>I<FF83F81E01E01C00C00E00800E00800E008007010007010003820003820003
+820001C40001C40001EC0000E80000E80000700000700000700000200015147F9318>I<
+FF9FE1FC3C0780701C0300601C0380200E0380400E0380400E03C0400707C0800704C080
+0704E080038861000388710003C8730001D0320001D03A0000F03C0000E01C0000E01C00
+00601800004008001E147F9321>I<7FC3FC0F01E00701C007018003810001C20000E400
+00EC00007800003800003C00007C00004E000087000107000303800201C00601E01E01E0
+FF07FE1714809318>I<FF83F81E01E01C00C00E00800E00800E00800701000701000382
+0003820003820001C40001C40001EC0000E80000E8000070000070000070000020000020
+00004000004000004000F08000F08000F100006200003C0000151D7F9318>I<3FFF380E
+200E201C40384078407000E001E001C00380078007010E011E011C0338027006700EFFFE
+10147F9314>I<FFFFFC1601808C17>I<FFFFFFFFFFF02C01808C2D>I
+E /Fi 18 122 df<000003800000000007C00000000007C0000000000FE0000000000FE0
+000000000FE0000000001FF0000000001FF0000000003FF8000000003FF8000000003FF8
+0000000073FC0000000073FC00000000F3FE00000000E1FE00000000E1FE00000001C0FF
+00000001C0FF00000003C0FF80000003807F80000007807FC0000007003FC0000007003F
+C000000E003FE000000E001FE000001E001FF000001C000FF000001FFFFFF000003FFFFF
+F800003FFFFFF80000780007FC0000700003FC0000700003FC0000E00001FE0000E00001
+FE0001E00001FF0001C00000FF0001C00000FF00FFFE001FFFFEFFFE001FFFFEFFFE001F
+FFFE2F297EA834>65 D<FFFE0000001FFFC0FFFE0000001FFFC0FFFF0000003FFFC003FF
+0000003FF00003FF0000003FF00003BF80000077F00003BF80000077F000039FC00000E7
+F000039FC00000E7F000038FE00001C7F000038FE00001C7F0000387F0000387F0000387
+F0000387F0000387F0000387F0000383F8000707F0000383F8000707F0000381FC000E07
+F0000381FC000E07F0000380FE001C07F0000380FE001C07F0000380FF003807F0000380
+7F003807F00003807F003807F00003803F807007F00003803F807007F00003801FC0E007
+F00003801FC0E007F00003800FE1C007F00003800FE1C007F00003800FE1C007F0000380
+07F38007F000038007F38007F000038003FF0007F000038003FF0007F000038001FE0007
+F000038001FE0007F000038000FC0007F000038000FC0007F000FFFE00FC01FFFFC0FFFE
+007801FFFFC0FFFE007801FFFFC03A297DA841>77 D<FFFFFFE00000FFFFFFFE0000FFFF
+FFFF800003FC007FE00003FC000FF00003FC0007F80003FC0007FC0003FC0003FC0003FC
+0003FE0003FC0003FE0003FC0003FE0003FC0003FE0003FC0003FE0003FC0003FE0003FC
+0003FC0003FC0007F80003FC0007F80003FC001FE00003FC007FC00003FFFFFE000003FF
+FFF0000003FC00FC000003FC007F000003FC003F800003FC003F800003FC001FC00003FC
+001FE00003FC001FE00003FC001FE00003FC001FE00003FC001FE00003FC001FF00003FC
+001FF00003FC001FF00003FC001FF00703FC001FF80703FC000FF80703FC0007F80EFFFF
+F003FE1CFFFFF001FFF8FFFFF0003FF030297DA834>82 D<007F806003FFF0E007FFF9E0
+0F807FE01F001FE03E0007E07C0003E07C0001E0FC0001E0FC0001E0FC0000E0FE0000E0
+FE0000E0FF000000FFC000007FFE00007FFFE0003FFFFC001FFFFE000FFFFF8007FFFFC0
+03FFFFE000FFFFE00007FFF000007FF000000FF8000007F8000003F8600001F8E00001F8
+E00001F8E00001F8F00001F0F00001F0F80003F0FC0003E0FF0007C0FFE01F80F3FFFF00
+E0FFFE00C01FF0001D297CA826>I<001FF80000FFFE0003F01F0007E03F800FC03F801F
+803F803F801F007F800E007F0000007F000000FF000000FF000000FF000000FF000000FF
+000000FF000000FF0000007F0000007F0000007F8000003F8001C01F8001C00FC0038007
+E0070003F01E0000FFFC00001FE0001A1B7E9A1F>99 D<00003FF80000003FF80000003F
+F800000003F800000003F800000003F800000003F800000003F800000003F800000003F8
+00000003F800000003F800000003F800000003F800000003F800001FE3F80000FFFBF800
+03F03FF80007E00FF8000FC007F8001F8003F8003F8003F8007F0003F8007F0003F8007F
+0003F800FF0003F800FF0003F800FF0003F800FF0003F800FF0003F800FF0003F800FF00
+03F8007F0003F8007F0003F8007F0003F8003F8003F8001F8003F8000F8007F80007C00F
+F80003F03BFF8000FFF3FF80003FC3FF80212A7EA926>I<003FE00001FFF80003F07E00
+07C01F000F801F801F800F803F800FC07F000FC07F0007C07F0007E0FF0007E0FF0007E0
+FFFFFFE0FFFFFFE0FF000000FF000000FF0000007F0000007F0000007F0000003F8000E0
+1F8000E00FC001C007E0038003F81F0000FFFE00001FF0001B1B7E9A20>I<0007F0003F
+FC00FE3E01F87F03F87F03F07F07F07F07F03E07F00007F00007F00007F00007F00007F0
+0007F000FFFFC0FFFFC0FFFFC007F00007F00007F00007F00007F00007F00007F00007F0
+0007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F0
+0007F0007FFF807FFF807FFF80182A7EA915>I<FFE0000000FFE0000000FFE00000000F
+E00000000FE00000000FE00000000FE00000000FE00000000FE00000000FE00000000FE0
+0000000FE00000000FE00000000FE00000000FE00000000FE07F00000FE1FFC0000FE787
+E0000FEE03F0000FF803F0000FF803F8000FF003F8000FF003F8000FE003F8000FE003F8
+000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F800
+0FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F800FF
+FE3FFF80FFFE3FFF80FFFE3FFF80212A7DA926>104 D<FFE0FFE0FFE00FE00FE00FE00F
+E00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00F
+E00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE0FFFEFFFEFFFE0F
+2A7DA914>108 D<FFC07F800FF000FFC1FFE03FFC00FFC383F0707E000FC603F8C07F00
+0FCC01F9803F000FD801FF003F800FF001FE003F800FF001FE003F800FE001FC003F800F
+E001FC003F800FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F800FE0
+01FC003F800FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F800FE001
+FC003F800FE001FC003F800FE001FC003F800FE001FC003F800FE001FC003F80FFFE1FFF
+C3FFF8FFFE1FFFC3FFF8FFFE1FFFC3FFF8351B7D9A3A>I<FFC07F0000FFC1FFC000FFC7
+87E0000FCE03F0000FD803F0000FD803F8000FF003F8000FF003F8000FE003F8000FE003
+F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8
+000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F800
+FFFE3FFF80FFFE3FFF80FFFE3FFF80211B7D9A26>I<003FE00001FFFC0003F07E000FC0
+1F801F800FC03F800FE03F0007E07F0007F07F0007F07F0007F0FF0007F8FF0007F8FF00
+07F8FF0007F8FF0007F8FF0007F8FF0007F8FF0007F87F0007F07F0007F03F800FE03F80
+0FE01F800FC00FC01F8007F07F0001FFFC00003FE0001D1B7E9A22>I<FFC1F0FFC7FCFF
+CE3E0FD87F0FD87F0FF07F0FF03E0FF01C0FE0000FE0000FE0000FE0000FE0000FE0000F
+E0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE0000FE000FFFF00FFFF00FF
+FF00181B7E9A1C>114 D<03FE300FFFF01E03F03800F0700070F00070F00070F80070FC
+0000FFE0007FFE007FFF803FFFE01FFFF007FFF800FFF80003FC0000FC60007CE0003CF0
+003CF00038F80038FC0070FF01E0F7FFC0C1FF00161B7E9A1B>I<007000007000007000
+00700000F00000F00000F00001F00003F00003F00007F0001FFFF0FFFFF0FFFFF007F000
+07F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F00007F000
+07F03807F03807F03807F03807F03807F03803F03803F87001F86000FFC0001F8015267F
+A51B>I<FFE03FF800FFE03FF800FFE03FF8000FE003F8000FE003F8000FE003F8000FE0
+03F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003
+F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8000FE003F8
+000FE007F80007E007F80007E00FF80003F03BFF8001FFF3FF80003FC3FF80211B7D9A26
+>I<FFFE03FF80FFFE03FF80FFFE03FF8007F000700007F000700007F800F00003F800E0
+0003FC01E00001FC01C00001FC01C00000FE03800000FE038000007F070000007F070000
+007F8F0000003F8E0000003FDE0000001FDC0000001FDC0000000FF80000000FF8000000
+0FF800000007F000000007F000000003E000000003E000000001C000000001C000000003
+800000000380000038078000007C07000000FE0F000000FE0E000000FE1E000000FE3C00
+00007C780000003FE00000000FC000000021277F9A24>121 D E
+end
+%%EndProlog
+%%BeginSetup
+%%Feature: *Resolution 300dpi
+TeXDict begin
+
+%%EndSetup
+%%Page: 1 1
+1 0 bop 424 311 a Fi(Another)23 b(Mo)r(dule)f(System)g(for)i(Sc)n(heme)
+825 407 y Fh(Jonathan)16 b(Rees)542 463 y(3)f(Jan)o(uary)g(1993)f(\(up)
+q(dated)i(15)e(Jan)o(uary)h(1994\))295 614 y(This)e(memo)g(describ)q
+(es)h(a)f(mo)q(dule)h(system)e(for)g(the)h(Sc)o(heme)h(programming)e
+(lan-)224 670 y(guage.)19 b(The)13 b(mo)q(dule)h(system)e(is)h(unique)i
+(in)e(the)g(exten)o(t)g(to)f(whic)o(h)i(it)f(supp)q(orts)f(b)q(oth)224
+727 y(static)k(linking)i(and)f(rapid)g(turnaround)f(during)h(program)e
+(dev)o(elopmen)o(t.)24 b(The)16 b(de-)224 783 y(sign)g(w)o(as)e
+(in\015uenced)k(b)o(y)d(Standard)h(ML)f(mo)q(dules[4])g(and)h(b)o(y)f
+(the)g(mo)q(dule)i(system)224 840 y(for)h(Sc)o(heme)g(Xero)o(x[3)o(].)
+29 b(It)18 b(has)g(also)g(b)q(een)h(shap)q(ed)g(b)o(y)f(the)g(needs)h
+(of)f(Sc)o(heme)g(48,)224 896 y(a)i(virtual-mac)o(hine-based)i(Sc)o
+(heme)f(implemen)o(tation)g(designed)g(to)e(run)i(b)q(oth)f(on)224
+953 y(w)o(orkstations)g(and)h(on)f(relativ)o(ely)i(small)g(\(less)f
+(than)g(1)f(Mb)o(yte\))g(em)o(b)q(edded)i(con-)224 1009
+y(trollers.)295 1065 y(Except)10 b(where)g(noted,)h(ev)o(erything)g
+(describ)q(ed)h(here)f(is)f(implemen)o(ted)i(in)f(Sc)o(heme)g(48,)224
+1122 y(and)k(exercised)i(b)o(y)e(the)g(Sc)o(heme)h(48)e(implemen)o
+(tation)j(and)e(a)g(few)g(application)i(pro-)224 1178
+y(grams.)295 1235 y(Unlik)o(e)g(the)e(Common)f(Lisp)j(pac)o(k)m(age)e
+(system,)g(the)g(mo)q(dule)i(system)e(describ)q(ed)224
+1291 y(here)22 b(con)o(trols)g(the)f(mapping)i(of)e(names)h(to)f
+(denotations,)i(not)e(the)h(mapping)g(of)224 1348 y(strings)15
+b(to)g(sym)o(b)q(ols.)224 1468 y Fg(In)n(tro)r(duction)224
+1553 y Fh(The)h(mo)q(dule)h(system)e(supp)q(orts)g(the)h(structured)f
+(division)j(of)d(a)g(corpus)h(of)f(Sc)o(heme)224 1610
+y(soft)o(w)o(are)10 b(in)o(to)i(a)g(set)f(of)h(mo)q(dules.)20
+b(Eac)o(h)12 b(mo)q(dule)h(has)e(its)h(o)o(wn)g(isolated)h(namespace,)
+224 1666 y(with)21 b(visibilit)o(y)i(of)d(bindings)i(con)o(trolled)f(b)
+o(y)f(mo)q(dule)i(descriptions)f(written)g(in)g(a)224
+1723 y(sp)q(ecial)c Ff(c)n(on\014gur)n(ation)f(language.)295
+1779 y Fh(A)i(mo)q(dule)h(ma)o(y)e(b)q(e)i(instan)o(tiated)f(m)o
+(ultiple)i(times,)e(pro)q(ducing)h(sev)o(eral)f Ff(p)n(ack-)224
+1836 y(ages)p Fh(,)c(just)f(as)h(a)f(lam)o(b)q(da-expression)j(can)e(b)
+q(e)g(instan)o(tiated)g(m)o(ultiple)i(times)e(to)g(pro-)224
+1892 y(duce)20 b(sev)o(eral)e(di\013eren)o(t)h(pro)q(cedures.)31
+b(Since)21 b(single)f(instan)o(tiation)f(is)g(the)g(normal)224
+1949 y(case,)12 b(I)g(will)h(defer)f(discussion)h(of)e(m)o(ultiple)j
+(instan)o(tiation)e(un)o(til)g(a)f(later)h(section.)19
+b(F)l(or)224 2005 y(no)o(w)c(y)o(ou)h(can)g(think)g(of)g(a)f(pac)o(k)m
+(age)h(as)f(simply)j(a)d(mo)q(dule's)i(in)o(ternal)f(en)o(vironmen)o(t)
+224 2061 y(mapping)g(names)f(to)g(denotations.)295 2118
+y(A)d(mo)q(dule)h(exp)q(orts)f(bindings)i(b)o(y)e(pro)o(viding)h(views)
+g(on)o(to)e(the)h(underlying)i(pac)o(k-)224 2174 y(age.)19
+b(Suc)o(h)13 b(a)f(view)h(is)h(called)g(a)e Ff(structur)n(e)h
+Fh(\(terminology)f(from)g(Standard)h(ML\).)f(One)224
+2231 y(mo)q(dule)17 b(ma)o(y)f(pro)o(vide)g(sev)o(eral)g(di\013eren)o
+(t)g(views.)23 b(A)16 b(structure)g(is)g(just)g(a)g(subset)g(of)224
+2287 y(the)22 b(pac)o(k)m(age's)f(bindings.)40 b(The)22
+b(particular)g(set)f(of)g(names)g(whose)h(bindings)h(are)224
+2344 y(exp)q(orted)16 b(is)f(the)h(structure's)e Ff(interfac)n(e)p
+Fh(.)295 2400 y(A)21 b(mo)q(dule)h(imp)q(orts)g(bindings)h(from)d
+(other)h(mo)q(dules)i(b)o(y)e(either)h Ff(op)n(ening)e
+Fh(or)224 2457 y Ff(ac)n(c)n(essing)9 b Fh(some)h(structures)h(that)f
+(are)g(built)i(on)f(other)f(pac)o(k)m(ages.)18 b(When)11
+b(a)g(structure)960 2581 y(1)p eop
+%%Page: 2 2
+2 1 bop 224 311 a Fh(is)11 b(op)q(ened,)h(all)f(of)f(its)g(exp)q(orted)
+h(bindings)h(are)e(visible)i(in)g(the)e(clien)o(t)h(pac)o(k)m(age.)19
+b(On)10 b(the)224 368 y(other)15 b(hand,)h(bindings)i(from)d(an)g
+(accessed)h(structure)g(require)g(explicitly)j(quali\014ed)224
+424 y(references)d(written)f(with)h(the)f Fe(structure-ref)e
+Fh(op)q(erator.)295 481 y(F)l(or)h(example:)320 557 y
+Fe(\(define-structure)21 b(foo)j(\(export)f(a)g(c)h(cons\))367
+613 y(\(open)g(scheme\))367 670 y(\(begin)f(\(define)g(a)h(1\))534
+726 y(\(define)f(\(b)h(x\))f(\(+)h(a)g(x\)\))534 782
+y(\(define)f(\(c)h(y\))f(\(*)h(\(b)g(a\))f(y\)\)\)\))320
+878 y(\(define-structure)e(bar)j(\(export)f(d\))367 935
+y(\(open)h(scheme)f(foo\))367 991 y(\(begin)g(\(define)g(\(d)h(w\))f
+(\(+)h(a)g(\(c)f(w\)\)\)\)\))224 1067 y Fh(This)d(con\014guration)f
+(de\014nes)h(t)o(w)o(o)d(structures,)i Fe(foo)f Fh(and)i
+Fe(bar)p Fh(.)30 b Fe(foo)18 b Fh(is)i(a)e(view)i(on)224
+1123 y(a)c(pac)o(k)m(age)h(in)g(whic)o(h)h(the)f Fe(scheme)e
+Fh(structure's)h(bindings)j(\(including)g Fe(define)c
+Fh(and)224 1180 y Fe(+)p Fh(\))21 b(are)g(visible,)j(together)c(with)i
+(bindings)h(for)d Fe(a)p Fh(,)i Fe(b)p Fh(,)h(and)e Fe(c)p
+Fh(.)37 b Fe(foo)p Fh('s)21 b(in)o(terface)g(is)224 1236
+y Fe(\(export)i(a)h(c)g(cons\))p Fh(,)13 b(so)i(of)f(the)h(bindings)i
+(in)f(its)f(underlying)i(pac)o(k)m(age,)d Fe(foo)h Fh(only)224
+1293 y(exp)q(orts)20 b(those)f(three.)33 b(Similarly)l(,)23
+b(structure)c Fe(bar)g Fh(consists)h(of)f(the)h(binding)i(of)d
+Fe(d)224 1349 y Fh(from)13 b(a)f(pac)o(k)m(age)i(in)f(whic)o(h)h(b)q
+(oth)g Fe(scheme)p Fh('s)e(and)h Fe(foo)p Fh('s)f(bindings)j(are)e
+(visible.)21 b Fe(foo)p Fh('s)224 1406 y(binding)13 b(of)d
+Fe(cons)g Fh(is)h(imp)q(orted)h(from)e(the)h(Sc)o(heme)g(structure)f
+(and)h(then)g(re-exp)q(orted.)295 1462 y(A)22 b(mo)q(dule's)g(b)q(o)q
+(dy)l(,)i(the)e(part)f(follo)o(wing)h Fe(begin)f Fh(in)i(the)f(ab)q(o)o
+(v)o(e)f(example,)j(is)224 1519 y(ev)m(aluated)c(in)g(an)f(isolated)h
+(lexical)h(scop)q(e)e(completely)h(sp)q(eci\014ed)i(b)o(y)c(the)i(pac)o
+(k)m(age)224 1575 y(de\014nition's)d Fe(open)d Fh(and)i
+Fe(access)e Fh(clauses.)21 b(In)16 b(particular,)g(the)f(binding)i(of)e
+(the)g(syn-)224 1631 y(tactic)h(op)q(erator)e Fe(define-structure)f
+Fh(is)j(not)f(visible)i(unless)g(it)e(comes)g(from)g(some)224
+1688 y(op)q(ened)i(structure.)j(Similarly)l(,)d(bindings)g(from)e(the)h
+Fe(scheme)e Fh(structure)h(aren't)g(vis-)224 1744 y(ible)22
+b(unless)g(they)f(b)q(ecome)g(so)f(b)o(y)h Fe(scheme)f
+Fh(\(or)f(an)i(equiv)m(alen)o(t)h(structure\))e(b)q(eing)224
+1801 y(op)q(ened.)224 1919 y Fg(The)f(con\014guration)f(language)224
+2005 y Fh(The)e(con\014guration)g(language)f(consists)h(of)f(top-lev)o
+(el)i(de\014ning)g(forms)e(for)f(mo)q(dules)224 2061
+y(and)i(in)o(terfaces.)k(Its)15 b(syn)o(tax)f(is)i(giv)o(en)g(in)g
+(\014gure)f(1.)295 2118 y(A)c Fe(define-structure)d Fh(form)i(in)o(tro)
+q(duces)i(a)e(binding)j(of)d(a)h(name)g(to)f(a)g(structure.)224
+2174 y(A)i(structure)g(is)h(a)f(view)g(on)g(an)h(underlying)h(pac)o(k)m
+(age)e(whic)o(h)h(is)f(created)h(according)f(to)224 2231
+y(the)i(clauses)h(of)f(the)g Fe(define-structure)e Fh(form.)19
+b(Eac)o(h)14 b(structure)g(has)g(an)g(in)o(terface)224
+2287 y(that)j(sp)q(eci\014es)j(whic)o(h)e(bindings)i(in)f(the)e
+(structure's)h(underlying)h(pac)o(k)m(age)f(can)g(b)q(e)224
+2344 y(seen)e(via)f(that)g(structure)g(in)h(other)f(pac)o(k)m(ages.)295
+2400 y(An)c Fe(open)g Fh(clause)i(sp)q(eci\014es)g(whic)o(h)f
+(structures)f(will)i(b)q(e)g(op)q(ened)f(up)g(for)f(use)h(inside)224
+2457 y(the)18 b(new)f(pac)o(k)m(age.)26 b(A)o(t)17 b(least)g(one)h(pac)
+o(k)m(age)f(m)o(ust)g(b)q(e)h(sp)q(eci\014ed)h(or)e(else)h(it)g(will)h
+(b)q(e)960 2581 y(2)p eop
+%%Page: 3 3
+3 2 bop 224 355 a Fd(h)p Fh(con\014guration)p Fd(i)15
+b(\000)-7 b(!)15 b(h)p Fh(de\014nition)p Fd(i)845 339
+y Fc(\003)224 411 y Fd(h)p Fh(de\014nition)p Fd(i)i(\000)-8
+b(!)31 b Fe(\(define-structure)22 b Fd(h)p Fh(name)p
+Fd(i)h(h)p Fh(in)o(terface)p Fd(i)g(h)p Fh(clause)p Fd(i)1543
+395 y Fc(\003)1562 411 y Fe(\))522 468 y Fd(j)30 b Fe
+(\(define-structures)21 b(\(\()p Fd(h)p Fh(name)p Fd(i)i(h)p
+Fh(in)o(terface)p Fd(i)p Fe(\))1460 451 y Fc(\003)1480
+468 y Fe(\))g Fd(h)p Fh(clause)p Fd(i)1682 451 y Fc(\003)1701
+468 y Fe(\))522 524 y Fd(j)30 b Fe(\(define-interface)22
+b Fd(h)p Fh(name)p Fd(i)h(h)p Fh(in)o(terface)p Fd(i)p
+Fe(\))522 581 y Fd(j)30 b Fe(\(define-syntax)22 b Fd(h)p
+Fh(name)p Fd(i)h(h)p Fh(transformer-sp)q(ec)p Fd(i)o
+Fe(\))224 637 y Fd(h)p Fh(clause)p Fd(i)16 b(\000)-8
+b(!)31 b Fe(\(open)23 b Fd(h)p Fh(name)p Fd(i)782 621
+y Fc(\003)801 637 y Fe(\))454 694 y Fd(j)30 b Fe(\(access)23
+b Fd(h)p Fh(name)p Fd(i)829 677 y Fc(\003)849 694 y Fe(\))454
+750 y Fd(j)30 b Fe(\(begin)23 b Fd(h)p Fh(program)p Fd(i)n
+Fe(\))454 807 y Fd(j)30 b Fe(\(files)23 b Fd(h)p Fh(\014lesp)q(ec)p
+Fd(i)842 790 y Fc(\003)862 807 y Fe(\))454 863 y Fd(j)30
+b Fe(\(optimize)23 b Fd(h)p Fh(optimize-sp)q(ec)p Fd(i)1040
+847 y Fc(\003)1060 863 y Fe(\))454 920 y Fd(j)30 b Fe(\(for-syntax)23
+b Fd(h)p Fh(clause)p Fd(i)938 903 y Fc(\003)958 920 y
+Fe(\))224 976 y Fd(h)p Fh(in)o(terface)p Fd(i)15 b(\000)-7
+b(!)31 b Fe(\(export)22 b Fd(h)p Fh(item)p Fd(i)862 960
+y Fc(\003)882 976 y Fe(\))505 1032 y Fd(j)30 b(h)p Fh(name)p
+Fd(i)505 1089 y(j)g Fe(\(compound-interface)21 b Fd(h)p
+Fh(in)o(terface)p Fd(i)1229 1072 y Fc(\003)1249 1089
+y Fe(\))224 1145 y Fd(h)p Fh(item)p Fd(i)15 b(\000)-7
+b(!)31 b(h)p Fh(name)p Fd(i)e(j)h Fe(\()p Fd(h)p Fh(name)p
+Fd(i)23 b(h)p Fh(t)o(yp)q(e)p Fd(i)p Fe(\))h Fd(j)47
+b Fe(\(\()p Fd(h)p Fh(name)p Fd(i)1290 1129 y Fc(\003)1310
+1145 y Fe(\))24 b Fd(h)p Fh(t)o(yp)q(e)p Fd(i)o Fe(\))594
+1293 y Fh(Figure)15 b(1:)20 b(The)15 b(con\014guration)h(language.)224
+1428 y(imp)q(ossible)k(to)e(write)g(an)o(y)f(useful)j(programs)c
+(inside)k(the)e(pac)o(k)m(age,)h(since)g Fe(define)p
+Fh(,)224 1485 y Fe(lambda)p Fh(,)12 b Fe(cons)p Fh(,)h
+Fe(structure-ref)p Fh(,)e(etc.)h(will)j(b)q(e)e(una)o(v)m(ailable.)22
+b(T)o(ypical)13 b(pac)o(k)m(ages)g(to)224 1541 y(list)h(in)g(the)f
+Fe(open)f Fh(clause)i(are)e Fe(scheme)p Fh(,)g(whic)o(h)i(exp)q(orts)f
+(all)h(bindings)g(appropriate)f(to)224 1598 y(Revised)376
+1581 y Fb(5)413 1598 y Fh(Sc)o(heme,)i(and)g Fe(structure-refs)p
+Fh(,)e(whic)o(h)j(exp)q(orts)f(the)g Fe(structure-ref)224
+1654 y Fh(op)q(erator)h(\(see)g(b)q(elo)o(w\).)25 b(F)l(or)16
+b(building)j(structures)d(that)g(exp)q(ort)g(structures,)g(there)224
+1711 y(is)22 b(a)e Fe(defpackage)g Fh(pac)o(k)m(age)h(that)f(exp)q
+(orts)h(the)g(op)q(erators)f(of)g(the)h(con\014guration)224
+1767 y(language.)29 b(Man)o(y)17 b(other)g(structures,)h(suc)o(h)h(as)e
+(record)h(and)g(hash)g(table)h(facilities,)224 1823 y(are)c(also)g(a)o
+(v)m(ailable)i(in)f(the)f(Sc)o(heme)h(48)f(implemen)o(tation.)295
+1880 y(An)e Fe(access)f Fh(clause)i(sp)q(eci\014es)h(whic)o(h)f
+(bindings)h(of)e(names)g(to)f(structures)h(will)i(b)q(e)224
+1936 y(visible)e(inside)f(the)e(pac)o(k)m(age)h(b)q(o)q(dy)g(for)e(use)
+i(in)g Fe(structure-ref)d Fh(forms.)18 b Fe(structure-)224
+1993 y(ref)d Fh(has)g(the)g(follo)o(wing)h(syn)o(tax:)315
+2084 y Fd(h)p Fh(expression)p Fd(i)f(\000)-7 b(!)31 b
+Fe(\(structure-ref)22 b Fd(h)p Fh(struct-name)p Fd(i)h(h)p
+Fh(name)p Fd(i)o Fe(\))224 2174 y Fh(The)14 b Fd(h)p
+Fh(struct-name)p Fd(i)f Fh(m)o(ust)g(b)q(e)h(the)g(name)f(of)g(an)h
+Fe(access)p Fh(ed)f(structure,)g(and)h Fd(h)p Fh(name)p
+Fd(i)224 2231 y Fh(m)o(ust)20 b(b)q(e)i(something)f(that)f(the)h
+(structure)f(exp)q(orts.)36 b(Only)22 b(structures)f(listed)h(in)224
+2287 y(an)17 b Fe(access)f Fh(clause)i(are)e(v)m(alid)j(in)f(a)e
+Fe(structure-ref)p Fh(.)23 b(If)17 b(a)g(pac)o(k)m(age)g(accesses)g(an)
+o(y)224 2344 y(structures,)g(it)g(should)h(probably)g(op)q(en)g(the)f
+Fe(structure-refs)e Fh(structure)i(so)f(that)224 2400
+y(the)f Fe(structure-ref)f Fh(op)q(erator)g(itself)i(will)h(b)q(e)f(a)o
+(v)m(ailable.)295 2457 y(The)g(pac)o(k)m(age's)g(b)q(o)q(dy)h(is)g(sp)q
+(eci\014ed)i(b)o(y)d Fe(begin)g Fh(and/or)f Fe(files)h
+Fh(clauses.)24 b Fe(begin)960 2581 y Fh(3)p eop
+%%Page: 4 4
+4 3 bop 224 311 a Fh(and)15 b Fe(files)e Fh(ha)o(v)o(e)h(the)g(same)g
+(seman)o(tics,)h(except)f(that)g(for)g Fe(begin)f Fh(the)h(text)g(is)h
+(giv)o(en)224 368 y(directly)j(in)g(the)f(pac)o(k)m(age)g
+(de\014nition,)i(while)g(for)d Fe(files)g Fh(the)h(text)g(is)g(stored)g
+(some-)224 424 y(where)k(in)h(the)g(\014le)g(system.)37
+b(The)21 b(b)q(o)q(dy)h(consists)f(of)g(a)f(Sc)o(heme)i(program,)f
+(that)224 481 y(is,)g(a)e(sequence)i(of)e(de\014nitions)i(and)e
+(expressions)i(to)e(b)q(e)h(ev)m(aluated)g(in)g(order.)33
+b(In)224 537 y(practice,)14 b(I)h(alw)o(a)o(ys)e(use)h
+Fe(files)f Fh(in)h(preference)h(to)e Fe(begin)p Fh(;)g
+Fe(begin)g Fh(exists)h(mainly)h(for)224 594 y(exp)q(ository)g(purp)q
+(oses.)295 650 y(A)g(name's)g(imp)q(orted)g(binding)j(ma)o(y)c(b)q(e)i
+(lexically)i(o)o(v)o(erridden)d(or)g Ff(shadowe)n(d)h
+Fh(b)o(y)224 707 y(simply)h(de\014ning)g(the)e(name)h(using)g(a)f
+(de\014ning)i(form)d(suc)o(h)i(as)f Fe(define)g Fh(or)g
+Fe(define-)224 763 y(syntax)p Fh(.)30 b(This)20 b(will)g(create)f(a)f
+(new)i(binding)g(without)f(ha)o(ving)g(an)o(y)g(e\013ect)g(on)f(the)224
+819 y(binding)25 b(in)e(the)g(op)q(ened)h(pac)o(k)m(age.)43
+b(F)l(or)22 b(example,)j(one)e(can)f(do)h Fe(\(define)g(car)224
+876 y('chevy\))13 b Fh(without)h(a\013ecting)g(the)g(binding)h(of)f
+(the)g(name)g Fe(car)f Fh(in)i(the)f Fe(scheme)e Fh(pac)o(k-)224
+932 y(age.)295 989 y(Assignmen)o(ts)17 b(\(using)h Fe(set!)p
+Fh(\))e(to)h(imp)q(orted)h(and)f(unde\014ned)i(v)m(ariables)g(are)e
+(not)224 1045 y(allo)o(w)o(ed.)22 b(In)17 b(order)f(to)f
+Fe(set!)g Fh(a)h(top-lev)o(el)h(v)m(ariable,)g(the)f(pac)o(k)m(age)f(b)
+q(o)q(dy)i(m)o(ust)e(con-)224 1102 y(tain)20 b(a)g Fe(define)f
+Fh(form)g(de\014ning)i(that)e(v)m(ariable.)35 b(Applied)22
+b(to)e(bindings)h(from)e(the)224 1158 y Fe(scheme)12
+b Fh(structure,)h(this)g(restriction)g(is)h(compatible)g(with)f(the)g
+(requiremen)o(ts)g(of)f(the)224 1215 y(Revised)376 1198
+y Fb(5)413 1215 y Fh(Sc)o(heme)k(rep)q(ort.)295 1271
+y(It)k(is)i(an)e(error)g(for)g(t)o(w)o(o)f(of)i(a)f(pac)o(k)m(age's)g
+(op)q(ened)i(structures)e(to)g(exp)q(ort)h(t)o(w)o(o)224
+1328 y(di\013eren)o(t)14 b(bindings)i(for)e(the)g(same)g(name.)19
+b(Ho)o(w)o(ev)o(er,)13 b(the)h(curren)o(t)g(implemen)o(tation)224
+1384 y(do)q(es)h(not)f(c)o(hec)o(k)g(for)g(this)h(situation;)f(a)g
+(name's)g(binding)j(is)d(alw)o(a)o(ys)g(tak)o(en)g(from)f(the)224
+1440 y(structure)18 b(that)g(is)h(listed)g(\014rst)f(within)h(the)g
+Fe(open)e Fh(clause.)30 b(This)19 b(ma)o(y)f(b)q(e)h(\014xed)g(in)224
+1497 y(the)c(future.)295 1553 y(File)i(names)e(in)i(a)f
+Fe(files)f Fh(clause)i(can)f(b)q(e)g(sym)o(b)q(ols,)g(strings,)g(or)f
+(lists)i(\(Maclisp-)224 1610 y(st)o(yle)g(\\namelists"\).)24
+b(A)16 b(\\)p Fe(.scm)p Fh(")g(\014le)h(t)o(yp)q(e)g(su\016x)g(is)g
+(assumed.)24 b(Sym)o(b)q(ols)17 b(are)f(con-)224 1666
+y(v)o(erted)f(to)e(\014le)j(names)e(b)o(y)h(con)o(v)o(erting)f(to)g
+(upp)q(er)i(or)e(lo)o(w)o(er)g(case)g(as)h(appropriate)f(for)224
+1723 y(the)19 b(host)f(op)q(erating)h(system.)29 b(A)19
+b(namelist)h(is)f(an)f(op)q(erating-system-indep)q(eden)o(t)224
+1779 y(w)o(a)o(y)11 b(to)f(sp)q(ecify)j(a)e(\014le)i(obtained)f(from)f
+(a)g(sub)q(directory)l(.)20 b(F)l(or)10 b(example,)j(the)f(namelist)224
+1836 y Fe(\(rts)23 b(record\))15 b Fh(sp)q(eci\014es)i(the)e(\014le)h
+Fe(record.scm)e Fh(in)i(the)f Fe(rts)g Fh(sub)q(directory)l(.)295
+1892 y(If)i(the)g Fe(define-structure)d Fh(form)i(w)o(as)g(itself)i
+(obtained)g(from)e(a)g(\014le,)i(then)f(\014le)224 1949
+y(names)c(in)g Fe(files)f Fh(clauses)i(are)f(in)o(terpreted)g(relativ)o
+(e)g(to)f(the)h(directory)g(in)h(whic)o(h)f(the)224 2005
+y(\014le)h(con)o(taining)g(the)f Fe(define-structure)e
+Fh(form)h(w)o(as)g(found.)20 b(Y)l(ou)13 b(can't)f(at)g(presen)o(t)224
+2061 y(put)j(an)h(absolute)f(path)g(name)g(in)h(the)g
+Fe(files)e Fh(list.)224 2183 y Fg(In)n(terfaces)224 2269
+y Fh(An)i(in)o(terface)f(can)h(b)q(e)g(though)o(t)f(of)g(as)g(the)g(t)o
+(yp)q(e)g(of)g(a)g(structure.)21 b(In)16 b(its)f(basic)h(form)224
+2325 y(it)g(is)f(just)g(a)g(list)h(of)f(v)m(ariable)i(names,)e(written)
+g Fe(\(export)23 b Ff(name)h Fa(:)8 b(:)g(:)n Fe(\))p
+Fh(.)20 b(Ho)o(w)o(ev)o(er,)14 b(in)224 2382 y(place)i(of)f(a)h(name)f
+(one)g(ma)o(y)g(write)h Fe(\()p Ff(name)23 b(typ)n(e)p
+Fe(\))p Fh(,)15 b(indicating)i(the)f(t)o(yp)q(e)f(of)g
+Ff(name)p Fh('s)224 2438 y(binding.)31 b(Curren)o(tly)18
+b(the)g(t)o(yp)q(e)h(\014eld)g(is)g(ignored,)g(except)f(that)g(exp)q
+(orted)g(macros)960 2581 y(4)p eop
+%%Page: 5 5
+5 4 bop 224 311 a Fh(m)o(ust)15 b(b)q(e)h(indicated)h(with)e(t)o(yp)q
+(e)g Fe(:syntax)p Fh(.)295 368 y(In)o(terfaces)g(ma)o(y)f(b)q(e)i
+(either)g(anon)o(ymous,)e(as)h(in)h(the)f(example)h(in)g(the)g(in)o
+(tro)q(duc-)224 424 y(tion,)d(or)e(they)h(ma)o(y)f(b)q(e)i(giv)o(en)f
+(names)g(b)o(y)g(a)f Fe(define-interface)f Fh(form,)h(for)h(example)320
+518 y Fe(\(define-interface)21 b(foo-interface)h(\(export)h(a)h(c)g
+(cons\)\))320 575 y(\(define-structure)d(foo)j(foo-interface)e
+Fa(:)8 b(:)g(:)n Fe(\))224 668 y Fh(In)k(principle,)i(in)o(terfaces)d
+(needn't)h(ev)o(er)f(b)q(e)g(named.)19 b(If)11 b(an)g(in)o(terface)h
+(had)f(to)f(b)q(e)i(giv)o(en)224 725 y(at)17 b(the)g(p)q(oin)o(t)h(of)e
+(a)h(structure's)g(use)g(as)g(w)o(ell)h(as)f(at)f(the)h(p)q(oin)o(t)h
+(of)f(its)g(de\014nition,)i(it)224 781 y(w)o(ould)h(b)q(e)h(imp)q
+(ortan)o(t)e(to)g(name)h(in)o(terfaces)g(in)h(order)e(to)h(a)o(v)o(oid)
+f(ha)o(ving)h(to)f(write)224 838 y(them)13 b(out)f(t)o(wice,)h(with)g
+(risk)g(of)g(mismatc)o(h)f(should)i(the)f(in)o(terface)g(ev)o(er)f(c)o
+(hange.)19 b(But)224 894 y(they)c(don't.)295 951 y(Still,)h(there)g
+(are)e(sev)o(eral)i(reasons)f(to)f(use)i Fe(define-interface)p
+Fh(:)280 1044 y(1.)22 b(It)c(is)h(imp)q(ortan)o(t)f(to)g(separate)f
+(the)i(in)o(terface)f(de\014nition)j(from)c(the)i(pac)o(k)m(age)338
+1101 y(de\014nitions)h(when)f(there)f(are)g(m)o(ultiple)i(distinct)g
+(structures)e(that)f(ha)o(v)o(e)h(the)338 1157 y(same)g(in)o(terface)h
+(|)h(that)e(is,)i(m)o(ultiple)g(implemen)o(tations)h(of)d(the)h(same)f
+(ab-)338 1214 y(straction.)280 1308 y(2.)k(It)17 b(is)g(conceptually)h
+(cleaner,)g(and)f(useful)h(for)e(do)q(cumen)o(tation)h(purp)q(oses,)g
+(to)338 1364 y(separate)f(a)h(mo)q(dule's)h(sp)q(eci\014cation)h(\(in)o
+(terface\))e(from)f(its)h(implemen)o(tation)338 1421
+y(\(pac)o(k)m(age\).)280 1514 y(3.)22 b(My)15 b(exp)q(erience)i(is)e
+(that)g(con\014gurations)g(that)f(are)h(separated)g(in)o(to)g(in)o
+(terface)338 1571 y(de\014nitions)i(and)f(pac)o(k)m(age)f
+(de\014nitions)j(are)d(easier)h(to)f(read;)g(the)h(long)g(lists)g(of)
+338 1627 y(exp)q(orted)f(bindings)i(just)e(get)g(in)h(the)f(w)o(a)o(y)g
+(most)f(of)h(the)g(time.)295 1721 y(The)g Fe(compound-interface)d
+Fh(op)q(erator)i(forms)g(an)g(in)o(terface)h(that)f(is)i(the)e(union)
+224 1778 y(of)h(t)o(w)o(o)f(or)g(more)h(comp)q(onen)o(t)h(in)o
+(terfaces.)k(F)l(or)14 b(example,)320 1871 y Fe(\(define-interface)21
+b(bar-interface)367 1928 y(\(compound-interface)h(foo-interface)g
+(\(export)h(mumble\)\)\))224 2022 y Fh(de\014nes)15 b
+Fe(bar-interface)c Fh(to)i(b)q(e)h Fe(foo-interface)e
+Fh(with)i(the)f(name)h Fe(mumble)e Fh(added.)224 2143
+y Fg(Macros)224 2229 y Fh(Hygienic)20 b(macros,)e(as)g(describ)q(ed)i
+(in)f([1)o(,)f(2],)g(are)g(implemen)o(ted.)31 b(Structures)18
+b(ma)o(y)224 2286 y(exp)q(ort)e(macros;)g(auxiliary)i(names)e(in)o(tro)
+q(duced)h(in)o(to)g(the)f(expansion)h(are)f(resolv)o(ed)224
+2342 y(in)g(the)f(en)o(vironmen)o(t)h(of)f(the)g(macro's)f
+(de\014nition.)295 2398 y(F)l(or)23 b(example,)k(the)d
+Fe(scheme)f Fh(structure's)g Fe(delay)g Fh(macro)h(is)g(de\014ned)i(b)o
+(y)d(the)224 2455 y(rewrite)15 b(rule)960 2581 y(5)p
+eop
+%%Page: 6 6
+6 5 bop 320 311 a Fe(\(delay)23 b Ff(exp)p Fe(\))47 b
+Fh(=)-8 b Fd(\))49 b Fe(\(make-promise)23 b(\(lambda)f(\(\))i
+Ff(exp)p Fe(\)\))p Fh(.)224 405 y(The)16 b(v)m(ariable)g
+Fe(make-promise)e Fh(is)i(de\014ned)g(in)g(the)g Fe(scheme)e
+Fh(structure's)h(underlying)224 462 y(pac)o(k)m(age,)j(but)g(is)g(not)f
+(exp)q(orted.)28 b(A)18 b(use)g(of)f(the)h Fe(delay)f
+Fh(macro,)g(ho)o(w)o(ev)o(er,)g(alw)o(a)o(ys)224 518
+y(accesses)f(the)g(correct)f(de\014nition)j(of)d Fe(make-promise)p
+Fh(.)20 b(Similarly)l(,)e(the)e Fe(case)f Fh(macro)224
+575 y(expands)i(in)o(to)g(uses)g(of)f Fe(cond)p Fh(,)g
+Fe(eqv?)p Fh(,)g(and)h(so)f(on.)25 b(These)17 b(names)f(are)h(exp)q
+(orted)g(b)o(y)224 631 y Fe(scheme)p Fh(,)e(but)h(their)h(correct)e
+(bindings)j(will)g(b)q(e)e(found)h(ev)o(en)f(if)g(they)g(are)g(shado)o
+(w)o(ed)224 687 y(b)o(y)f(de\014nitions)i(in)f(the)g(clien)o(t)g(pac)o
+(k)m(age.)224 809 y Fg(Higher-order)h(mo)r(dules)224
+895 y Fh(There)g(are)f Fe(define-module)e Fh(and)j Fe(define)e
+Fh(forms)g(for)h(de\014ning)i(mo)q(dules)f(that)f(are)224
+951 y(in)o(tended)g(to)d(b)q(e)i(instan)o(tiated)f(m)o(ultiple)i
+(times.)k(But)14 b(these)h(are)f(prett)o(y)f(kludgey)i(|)224
+1008 y(for)i(example,)h(compiled)g(co)q(de)g(isn't)f(shared)g(b)q(et)o
+(w)o(een)h(the)f(instan)o(tiations)g(|)g(so)g(I)224 1064
+y(w)o(on't)d(describ)q(e)i(them)f(y)o(et.)k(If)c(y)o(ou)f(m)o(ust)g
+(kno)o(w,)g(\014gure)h(it)g(out)f(from)g(the)h(follo)o(wing)224
+1121 y(grammar.)315 1215 y Fd(h)p Fh(de\014nition)p Fd(i)h(\000)-7
+b(!)31 b Fe(\(define-module)22 b(\()p Fd(h)p Fh(name)p
+Fd(i)h Fe(\()p Fd(h)p Fh(name)p Fd(i)g(h)p Fh(in)o(terface)p
+Fd(i)p Fe(\))1621 1198 y Fc(\003)1640 1215 y Fe(\))704
+1271 y Fd(h)p Fh(de\014nition)p Fd(i)926 1255 y Fc(\003)704
+1327 y Fd(h)p Fh(name)p Fd(i)o Fe(\))610 1384 y Fd(j)30
+b Fe(\(define)23 b Fd(h)p Fh(name)p Fd(i)g Fe(\()p Fd(h)p
+Fh(name)p Fd(i)h(h)p Fh(name)p Fd(i)1340 1367 y Fc(\003)1360
+1384 y Fe(\)\))224 1506 y Fg(Compiling)17 b(and)i(linking)224
+1591 y Fh(Sc)o(heme)f(48)e(has)h(a)g(static)f(link)o(er)i(that)f(pro)q
+(duces)g(stand-alone)h(heap)f(images)g(from)224 1648
+y(mo)q(dule)k(descriptions.)35 b(One)20 b(sp)q(eci\014es)i(a)d
+(particular)h(pro)q(cedure)h(in)f(a)g(particular)224
+1704 y(structure)c(to)f(b)q(e)i(the)f(image's)f(startup)g(pro)q(cedure)
+i(\(en)o(try)e(p)q(oin)o(t\),)h(and)g(the)g(link)o(er)224
+1761 y(traces)g(dep)q(endency)i(links)f(as)f(giv)o(en)g(b)o(y)g
+Fe(open)f Fh(and)h Fe(access)f Fh(clauses)i(to)e(determine)224
+1817 y(the)g(comp)q(osition)h(of)f(the)h(heap)f(image.)295
+1874 y(There)i(is)g(not)g(curren)o(tly)g(an)o(y)g(pro)o(vision)h(for)e
+(separate)g(compilation;)j(the)e(only)224 1930 y(input)j(to)f(the)g
+(static)g(link)o(er)h(is)g(source)f(co)q(de.)32 b(Ho)o(w)o(ev)o(er,)19
+b(it)h(will)g(not)f(b)q(e)h(di\016cult)224 1987 y(to)15
+b(implemen)o(t)i(separate)f(compilation.)23 b(The)16
+b(unit)h(of)e(compilation)i(is)f(one)g(mo)q(dule)224
+2043 y(\(not)j(one)g(\014le\).)32 b(An)o(y)19 b(op)q(ened)h(or)f
+(accessed)g(structures)g(from)g(whic)o(h)h(macros)e(are)224
+2100 y(obtained)13 b(m)o(ust)f(b)q(e)i(pro)q(cessed)f(to)f(the)h(exten)
+o(t)f(of)g(extracting)g(its)h(macro)f(de\014nitions.)224
+2156 y(The)18 b(compiler)g(kno)o(ws)f(from)g(the)g(in)o(terface)h(of)f
+(an)g(op)q(ened)i(or)e(accessed)h(structure)224 2212
+y(whic)o(h)24 b(of)e(its)h(exp)q(orts)f(are)g(macros.)42
+b(Except)23 b(for)f(macros,)h(a)f(mo)q(dule)i(ma)o(y)e(b)q(e)224
+2269 y(compiled)e(without)e(an)o(y)g(kno)o(wledge)h(of)e(the)i
+(implemen)o(tation)g(of)f(its)g(op)q(ened)h(and)224 2325
+y(accessed)h(structures.)31 b(Ho)o(w)o(ev)o(er,)19 b(in)o(ter-mo)q
+(dule)h(optimization)g(will)h(b)q(e)f(a)o(v)m(ailable)224
+2382 y(as)15 b(an)g(option.)960 2581 y(6)p eop
+%%Page: 7 7
+7 6 bop 295 311 a Fh(The)17 b(main)g(di\016cult)o(y)h(with)f(separate)g
+(compilation)h(is)f(resolution)h(of)e(auxiliary)224 368
+y(bindings)25 b(in)o(tro)q(duced)e(in)o(to)g(macro)f(expansions.)43
+b(The)22 b(mo)q(dule)i(compiler)g(m)o(ust)224 424 y(transmit)15
+b(to)f(the)h(loader)g(or)g(link)o(er)h(the)f(searc)o(h)f(path)h(b)o(y)g
+(whic)o(h)h(suc)o(h)f(bindings)i(are)224 481 y(to)h(b)q(e)i(resolv)o
+(ed.)31 b(In)19 b(the)g(case)f(of)h(the)g Fe(delay)f
+Fh(macro's)f(auxiliary)j Fe(make-promise)224 537 y Fh(\(see)g(example)g
+(ab)q(o)o(v)o(e\),)g(the)g(loader)g(or)f(link)o(er)i(needs)f(to)f(kno)o
+(w)h(that)f(the)g(desired)224 594 y(binding)h(of)d Fe(make-promise)e
+Fh(is)j(the)g(one)f(apparen)o(t)g(in)i Fe(delay)p Fh('s)d(de\014ning)j
+(pac)o(k)m(age,)224 650 y(not)c(in)h(the)f(pac)o(k)m(age)g(b)q(eing)i
+(loaded)f(or)f(link)o(ed.)295 707 y([I)g(need)h(to)f(describ)q(e)h
+(structure)f(rei\014cation.])224 828 y Fg(Seman)n(tics)i(of)i
+(con\014guration)g(m)n(utation)224 914 y Fh(During)c(program)f(dev)o
+(elopmen)o(t)h(it)g(is)h(often)e(desirable)i(to)e(mak)o(e)h(c)o(hanges)
+f(to)g(pac)o(k-)224 971 y(ages)k(and)h(in)o(terfaces.)31
+b(In)20 b(static)e(languages)h(it)g(ma)o(y)f(b)q(e)i(necessary)f(to)f
+(recompile)224 1027 y(and)d(re-link)g(a)f(program)f(in)j(order)e(for)f
+(suc)o(h)i(c)o(hanges)f(to)g(b)q(e)g(re\015ected)h(in)g(a)f(running)224
+1083 y(system.)35 b(Ev)o(en)20 b(in)i(in)o(teractiv)o(e)e(Common)g
+(Lisp)h(implemen)o(tations,)i(a)d(c)o(hange)g(to)224
+1140 y(a)c(pac)o(k)m(age's)g(exp)q(orts)g(often)f(requires)i(reloading)
+g(clien)o(ts)h(that)d(ha)o(v)o(e)h(already)g(men-)224
+1196 y(tioned)i(names)f(whose)g(bindings)i(c)o(hange.)25
+b(Once)18 b Fe(read)f Fh(resolv)o(es)g(a)g(use)g(of)g(a)f(name)224
+1253 y(to)i(a)g(sym)o(b)q(ol,)g(that)g(resolution)h(is)g(\014xed,)g(so)
+f(a)f(c)o(hange)i(in)g(the)f(w)o(a)o(y)f(that)h(a)f(name)224
+1309 y(resolv)o(es)e(to)f(a)g(sym)o(b)q(ol)h(can)f(only)h(b)q(e)h
+(re\015ected)f(b)o(y)f(re-)p Fe(read)p Fh(ing)h(all)g(suc)o(h)g
+(references.)295 1366 y(The)g(Sc)o(heme)h(48)e(dev)o(elopmen)o(t)i(en)o
+(vironmen)o(t)f(supp)q(orts)g(rapid)h(turnaround)f(in)224
+1422 y(mo)q(dular)j(program)f(dev)o(elopmen)o(t)i(b)o(y)e(allo)o(wing)i
+(m)o(utations)e(to)g(a)h(program's)e(con-)224 1479 y(\014guration,)f
+(and)g(giving)g(a)g(clear)g(seman)o(tics)g(to)f(suc)o(h)h(m)o
+(utations.)k(The)c(rule)h(is)f(that)224 1535 y(v)m(ariable)23
+b(bindings)f(in)g(a)f(running)h(program)e(are)h(alw)o(a)o(ys)f(resolv)o
+(ed)i(according)f(to)224 1592 y(curren)o(t)c(structure)g(and)g(in)o
+(terface)h(bindings,)h(ev)o(en)e(when)h(these)f(bindings)i(c)o(hange)
+224 1648 y(as)12 b(a)g(result)h(of)f(edits)h(to)f(the)h
+(con\014guration.)19 b(F)l(or)12 b(example,)h(consider)h(the)e(follo)o
+(wing:)320 1742 y Fe(\(define-interface)21 b(foo-interface)h(\(export)h
+(a)h(c\)\))320 1798 y(\(define-structure)d(foo)j(foo-interface)367
+1855 y(\(open)g(scheme\))367 1911 y(\(begin)f(\(define)g(a)h(1\))534
+1968 y(\(define)f(\(b)h(x\))f(\(+)h(a)g(x\)\))534 2024
+y(\(define)f(\(c)h(y\))f(\(*)h(\(b)g(a\))f(y\)\)\)\))320
+2081 y(\(define-structure)e(bar)j(\(export)f(d\))367
+2137 y(\(open)h(scheme)f(foo\))367 2193 y(\(begin)g(\(define)g(\(d)h
+(w\))f(\(+)h(\(b)g(w\))f(a\)\)\)\))224 2287 y Fh(This)18
+b(program)e(has)i(a)f(bug.)26 b(The)18 b(v)m(ariable)g
+Fe(b)p Fh(,)g(whic)o(h)g(is)g(free)f(in)h(the)g(de\014nition)h(of)224
+2344 y Fe(d)p Fh(,)i(has)f(no)g(binding)i(in)f Fe(bar)p
+Fh('s)e(pac)o(k)m(age.)35 b(Supp)q(ose)21 b(that)f Fe(b)g
+Fh(w)o(as)f(supp)q(osed)i(to)f(b)q(e)224 2400 y(exp)q(orted)f(b)o(y)f
+Fe(foo)p Fh(,)h(but)f(w)o(as)g(omitted)g(from)g Fe(foo-interface)e
+Fh(b)o(y)i(mistak)o(e.)30 b(It)18 b(is)224 2457 y(not)f(necessary)h(to)
+e(re-pro)q(cess)i Fe(bar)f Fh(or)g(an)o(y)g(of)g Fe(foo)p
+Fh('s)f(other)h(clien)o(ts)i(at)e(this)g(p)q(oin)o(t.)960
+2581 y(7)p eop
+%%Page: 8 8
+8 7 bop 224 311 a Fh(One)17 b(need)f(only)h(c)o(hange)f
+Fe(foo-interface)e Fh(and)i(inform)g(the)f(dev)o(elopmen)o(t)i(system)
+224 368 y(of)d(that)g(one)h(c)o(hange)f(\(using,)h(sa)o(y)l(,)f(an)g
+(appropriate)h(Emacs)f(command\),)g(and)g Fe(foo)p Fh('s)224
+424 y(binding)j(of)e Fe(b)g Fh(will)i(b)q(e)f(found)f(when)h(pro)q
+(cedure)g Fe(d)f Fh(is)h(called.)295 481 y(Similarly)l(,)e(it)e(is)f
+(also)h(p)q(ossible)h(to)e(replace)h(a)f(structure;)h(clien)o(ts)h(of)e
+(the)h(old)g(struc-)224 537 y(ture)g(will)i(b)q(e)e(mo)q(di\014ed)h(so)
+f(that)f(they)h(see)g(bindings)i(from)d(the)h(new)g(one.)19
+b(Shado)o(wing)224 594 y(is)e(also)g(supp)q(orted)g(in)h(the)f(same)f
+(w)o(a)o(y)l(.)24 b(Supp)q(ose)17 b(that)f(a)h(clien)o(t)h(pac)o(k)m
+(age)f Fa(C)i Fh(op)q(ens)224 650 y(a)f(structure)f Fe(foo)h
+Fh(that)f(exp)q(orts)g(a)h(name)f Fe(x)p Fh(,)h(and)g
+Fe(foo)p Fh('s)f(implemen)o(tation)i(obtains)224 707
+y(the)d(binding)i(of)e Fe(x)f Fh(as)h(an)g(imp)q(ort)g(from)f(some)h
+(other)f(structure)h Fe(bar)p Fh(.)22 b(Then)16 b Fa(C)j
+Fh(will)224 763 y(see)f(the)g(binding)i(from)d Fe(bar)p
+Fh(.)28 b(If)18 b(one)g(then)g(alters)g Fe(foo)f Fh(so)h(that)f(it)h
+(shado)o(ws)f Fe(bar)p Fh('s)224 819 y(binding)e(of)d
+Fe(x)g Fh(with)h(a)f(de\014nition)i(of)e(its)h(o)o(wn,)f(then)h(pro)q
+(cedures)g(in)h Fa(C)h Fh(that)d(reference)224 876 y
+Fe(x)19 b Fh(will)h(automatically)f(see)g Fe(foo)p Fh('s)f
+(de\014nition)j(instead)e(of)f(the)h(one)g(from)f Fe(bar)g
+Fh(that)224 932 y(they)d(sa)o(w)g(earlier.)295 989 y(This)c(seman)o
+(tics)f(migh)o(t)g(app)q(ear)g(to)g(require)h(a)f(large)g(amoun)o(t)g
+(of)f(computation)i(on)224 1045 y(ev)o(ery)j(v)m(ariable)i(reference:)k
+(The)14 b(sp)q(eci\014ed)i(b)q(eha)o(vior)f(requires)f(scanning)h(the)f
+(pac)o(k-)224 1102 y(age's)g(list)h(of)f(op)q(ened)i(structures,)e
+(examining)i(their)f(in)o(terfaces,)f(on)h(ev)o(ery)f(v)m(ariable)224
+1158 y(reference,)h(not)f(just)g(at)f(compile)j(time.)k(Ho)o(w)o(ev)o
+(er,)13 b(the)h(dev)o(elopmen)o(t)h(en)o(vironmen)o(t)224
+1215 y(uses)h(cac)o(hing)g(with)f(cac)o(he)h(in)o(v)m(alidation)h(to)e
+(mak)o(e)f(v)m(ariable)j(references)f(fast.)224 1336
+y Fg(Command)h(pro)r(cessor)h(supp)r(ort)224 1422 y Fh(While)f(it)e(is)
+g(p)q(ossible)i(to)e(use)g(the)g(Sc)o(heme)h(48)e(static)h(link)o(er)h
+(for)f(program)e(dev)o(elop-)224 1479 y(men)o(t,)i(it)h(is)g(far)e
+(more)h(con)o(v)o(enien)o(t)h(to)f(use)h(the)f(dev)o(elopmen)o(t)h(en)o
+(vironmen)o(t,)g(whic)o(h)224 1535 y(supp)q(orts)21 b(rapid)g
+(turnaround)f(for)g(program)f(c)o(hanges.)36 b(The)21
+b(programmer)e(in)o(ter-)224 1592 y(acts)13 b(with)i(the)e(dev)o
+(elopmen)o(t)i(en)o(vironmen)o(t)f(through)f(a)h Ff(c)n(ommand)h(pr)n
+(o)n(c)n(essor)p Fh(.)j(The)224 1648 y(command)d(pro)q(cessor)h(is)f
+(lik)o(e)i(the)e(usual)i(Lisp)f(read-ev)m(al-prin)o(t)h(lo)q(op)f(in)g
+(that)f(it)g(ac-)224 1704 y(cepts)k(Sc)o(heme)h(forms)e(to)g(ev)m
+(aluate.)31 b(Ho)o(w)o(ev)o(er,)18 b(all)i(meta-lev)o(el)g(op)q
+(erations,)f(suc)o(h)224 1761 y(as)e(exiting)h(the)f(Sc)o(heme)h
+(system)f(or)g(requests)g(for)f(trace)h(output,)g(are)g(handled)i(b)o
+(y)224 1817 y Ff(c)n(ommands,)f Fh(whic)o(h)h(are)e(lexically)j
+(distinguished)g(from)d(Sc)o(heme)h(forms.)27 b(This)18
+b(ar-)224 1874 y(rangemen)o(t)11 b(is)h(b)q(orro)o(w)o(ed)e(from)h(the)
+g(Sym)o(b)q(olics)i(Lisp)f(Mac)o(hine)g(system,)f(and)h(is)g(rem-)224
+1930 y(iniscen)o(t)19 b(of)d(non-Lisp)j(debuggers.)25
+b(Commands)17 b(are)g(a)f(little)j(easier)e(to)g(t)o(yp)q(e)g(than)224
+1987 y(Sc)o(heme)j(forms)f(\(no)g(paren)o(theses,)h(so)f(y)o(ou)g
+(don't)g(ha)o(v)o(e)g(to)f(shift\),)i(but)g(more)f(im-)224
+2043 y(p)q(ortan)o(tly)l(,)14 b(making)h(them)f(distinct)h(from)f(Sc)o
+(heme)h(forms)f(ensures)g(that)g(programs')224 2100 y(namespaces)f
+(aren't)g(clutterred)g(with)g(inappropriate)h(bindings.)21
+b(Equiv)m(alen)o(tly)l(,)15 b(the)224 2156 y(command)h(set)h(is)g(a)o
+(v)m(ailable)h(for)e(use)g(regardless)h(of)f(what)g(bindings)i(happ)q
+(en)g(to)e(b)q(e)224 2213 y(visible)j(in)e(the)f(curren)o(t)g(program.)
+22 b(This)16 b(is)h(esp)q(ecially)i(imp)q(ortan)o(t)c(in)i(conjunction)
+224 2269 y(with)e(the)f(mo)q(dule)h(system,)e(whic)o(h)i(puts)f(strict)
+g(con)o(trols)g(on)g(visibilit)o(y)i(of)e(bindings.)295
+2325 y(The)h(Sc)o(heme)h(48)e(command)h(pro)q(cessor)g(supp)q(orts)g
+(the)g(mo)q(dule)i(system)d(with)i(a)224 2382 y(v)m(ariet)o(y)h(of)e
+(sp)q(ecial)k(commands.)j(F)l(or)16 b(commands)g(that)g(require)h
+(structure)f(names,)224 2438 y(these)h(names)f(are)g(resolv)o(ed)h(in)g
+(a)f(designated)h(con\014guration)g(pac)o(k)m(age)f(that)g(is)h(dis-)
+960 2581 y(8)p eop
+%%Page: 9 9
+9 8 bop 224 311 a Fh(tinct)21 b(from)f(the)h(curren)o(t)f(pac)o(k)m
+(age)h(for)f(ev)m(aluating)h(Sc)o(heme)h(forms)d(giv)o(en)i(to)f(the)
+224 368 y(command)f(pro)q(cessor.)31 b(The)20 b(command)f(pro)q(cessor)
+f(in)o(terprets)i(Sc)o(heme)f(forms)g(in)224 424 y(a)d(particular)h
+(curren)o(t)f(pac)o(k)m(age,)g(and)g(there)h(are)e(commands)h(that)g
+(mo)o(v)o(e)f(the)i(com-)224 481 y(mand)e(pro)q(cessor)g(b)q(et)o(w)o
+(een)h(di\013eren)o(t)f(pac)o(k)m(ages.)295 537 y(Commands)h(are)h(in)o
+(tro)q(duced)h(b)o(y)e(a)h(comma)f(\()p Fe(,)p Fh(\))h(and)g(end)g(at)f
+(the)h(end)h(of)e(line.)224 594 y(The)f(command)f(pro)q(cessor's)f
+(prompt)h(consists)h(of)f(the)g(name)g(of)g(the)g(curren)o(t)g(pac)o
+(k-)224 650 y(age)h(follo)o(w)o(ed)g(b)o(y)h(a)e(greater-than)h(\()p
+Fe(>)p Fh(\).)338 756 y Fe(,config)338 831 y Fh(The)e
+Fe(,config)f Fh(command)h(sets)f(the)i(command)e(pro)q(cessor's)h
+(curren)o(t)g(pac)o(k)m(age)338 888 y(to)j(b)q(e)h(the)g(curren)o(t)g
+(con\014guration)g(pac)o(k)m(age.)25 b(F)l(orms)16 b(en)o(tered)h(at)f
+(this)h(p)q(oin)o(t)338 944 y(are)22 b(in)o(terpreted)h(as)g(b)q(eing)h
+(con\014guration)e(language)h(forms,)h(not)e(Sc)o(heme)338
+1001 y(forms.)338 1095 y Fe(,config)h Ff(c)n(ommand)338
+1170 y Fh(This)14 b(form)e(of)h(the)g Fe(,config)f Fh(command)h
+(executes)h(another)e(command)h(in)h(the)338 1226 y(curren)o(t)h
+(con\014guration)g(pac)o(k)m(age.)20 b(F)l(or)15 b(example,)433
+1320 y Fe(,config)23 b(,load)g(foo.scm)338 1414 y Fh(in)o(terprets)18
+b(con\014guration)g(language)h(forms)e(from)h(the)g(\014le)h
+Fe(foo.scm)e Fh(in)i(the)338 1470 y(curren)o(t)c(con\014guration)g(pac)
+o(k)m(age.)338 1564 y Fe(,in)23 b Ff(struct-name)338
+1639 y Fh(The)14 b Fe(,in)f Fh(command)g(mo)o(v)o(es)g(the)g(command)h
+(pro)q(cessor)f(to)g(a)g(sp)q(eci\014ed)j(struc-)338
+1696 y(ture's)e(underlying)k(pac)o(k)m(age.)h(F)l(or)c(example:)433
+1790 y Fe(user>)23 b(,config)433 1846 y(config>)g(\(define-structure)f
+(foo)h(\(export)g(a\))672 1902 y(\(open)g(scheme\)\))433
+1959 y(config>)g(,in)h(foo)433 2015 y(foo>)g(\(define)e(a)i(13\))433
+2072 y(foo>)g(a)433 2128 y(13)338 2222 y Fh(In)11 b(this)g(example)g
+(the)g(command)f(pro)q(cessor)h(starts)e(in)j(a)e(pac)o(k)m(age)g
+(called)i Fe(user)p Fh(,)338 2279 y(but)19 b(the)h Fe(,config)e
+Fh(command)h(mo)o(v)o(es)f(it)i(in)o(to)f(the)g(con\014guration)h(pac)o
+(k)m(age,)338 2335 y(whic)o(h)e(has)f(the)h(name)f Fe(config)p
+Fh(.)26 b(The)17 b Fe(define-structure)e Fh(form)i(binds,)i(in)338
+2391 y Fe(config)p Fh(,)j(the)g(name)g Fe(foo)g Fh(to)f(a)h(structure)f
+(that)h(exp)q(orts)f Fe(a)p Fh(.)40 b(Finally)l(,)25
+b(the)960 2581 y(9)p eop
+%%Page: 10 10
+10 9 bop 338 311 a Fh(command)13 b Fe(,in)23 b(foo)13
+b Fh(mo)o(v)o(es)f(the)h(command)g(pro)q(cessor)g(in)o(to)g(structure)f
+Fe(foo)p Fh('s)338 368 y(underlying)17 b(pac)o(k)m(age.)338
+443 y(A)11 b(pac)o(k)m(age's)f(b)q(o)q(dy)h(isn't)g(executed)h(\(ev)m
+(aluated\))f(un)o(til)g(the)g(pac)o(k)m(age)g(is)g Ff(lo)n(ade)n(d)p
+Fh(,)338 499 y(whic)o(h)16 b(is)g(accomplished)h(b)o(y)e(the)g
+Fe(,load-package)e Fh(command.)338 593 y Fe(,in)23 b
+Ff(struct-name)i(c)n(ommand)338 668 y Fh(This)e(form)e(of)h(the)g
+Fe(,in)g Fh(command)g(executes)h(a)f(single)h(command)f(in)h(the)338
+725 y(sp)q(eci\014ed)f(pac)o(k)m(age)e(without)h(mo)o(ving)f(the)g
+(command)g(pro)q(cessor)g(in)o(to)g(that)338 781 y(pac)o(k)m(age.)g
+(Example:)433 875 y Fe(,in)k(mumble)f(\(cons)g(1)h(2\))433
+932 y(,in)g(mumble)f(,trace)g(foo)338 1025 y(,user)g
+Fh([)p Ff(c)n(ommand)p Fh(])338 1100 y(This)d(is)h(similar)g(to)e(the)i
+Fe(,config)e Fh(and)h Fe(,in)f Fh(commands.)34 b(It)20
+b(mo)o(v)o(es)g(to)f(or)338 1157 y(executes)14 b(a)f(command)g(in)h
+(the)g(user)f(pac)o(k)m(age)g(\(whic)o(h)h(is)g(the)g(default)g(pac)o
+(k)m(age)338 1213 y(when)h(the)h(Sc)o(heme)g(48)e(command)h(pro)q
+(cessor)g(starts\).)338 1307 y Fe(,for-syntax)22 b Fh([)p
+Ff(c)n(ommand)p Fh(])338 1382 y(This)e(is)h(similar)g(to)e(the)i
+Fe(,config)e Fh(and)h Fe(,in)f Fh(commands.)34 b(It)20
+b(mo)o(v)o(es)g(to)f(or)338 1439 y(executes)h(a)f(command)g(in)i(the)e
+(curren)o(t)h(pac)o(k)m(age's)f(\\pac)o(k)m(age)g(for)g(syn)o(tax,")338
+1495 y(whic)o(h)e(is)g(the)f(pac)o(k)m(age)g(in)h(whic)o(h)g(the)g
+(forms)e Fa(f)22 b Fh(in)17 b Fe(\(define-syntax)22 b
+Ff(name)338 1552 y Fa(f)5 b Fe(\))15 b Fh(are)g(ev)m(aluated.)338
+1645 y Fe(,load-package)22 b Ff(struct-name)338 1721
+y Fh(The)d Fe(,load-package)e Fh(command)h(ensures)i(that)e(the)g(sp)q
+(eci\014ed)j(structure's)338 1777 y(underlying)g(pac)o(k)m(age's)d
+(program)g(has)h(b)q(een)h(loaded.)32 b(This)20 b(consists)f(of)f
+(\(1\))338 1834 y(recursiv)o(ely)13 b(ensuring)g(that)e(the)h(pac)o(k)m
+(ages)f(of)h(an)o(y)f(op)q(ened)i(or)e(accessed)i(struc-)338
+1890 y(tures)f(are)g(loaded,)i(follo)o(w)o(ed)e(b)o(y)h(\(2\))e
+(executing)j(the)e(pac)o(k)m(age's)g(b)q(o)q(dy)h(as)g(sp)q(ec-)338
+1946 y(i\014ed)j(b)o(y)f(its)h(de\014nition's)g Fe(begin)f
+Fh(and)g Fe(files)g Fh(forms.)338 2040 y Fe(,reload-package)22
+b Ff(struct-name)338 2115 y Fh(This)f(command)f(re-executes)h(the)g
+(structure's)f(pac)o(k)m(age's)g(program.)34 b(It)21
+b(is)338 2172 y(most)g(useful)i(if)g(the)f(program)e(comes)i(from)g(a)f
+(\014le)i(or)f(\014les,)i(when)f(it)f(will)338 2228 y(up)q(date)16
+b(the)f(pac)o(k)m(age's)g(bindings)i(after)d(m)o(utations)h(to)f(its)i
+(source)f(\014le.)338 2322 y Fe(,load)23 b Ff(\014lesp)n(e)n(c)f
+Fa(:)8 b(:)g(:)338 2397 y Fh(The)22 b Fe(,load)f Fh(command)g(executes)
+i(forms)e(from)g(the)h(sp)q(eci\014ed)i(\014le)e(or)g(\014les)338
+2454 y(in)16 b(the)g(curren)o(t)g(pac)o(k)m(age.)22 b
+Fe(,load)h Ff(\014lesp)n(e)n(c)14 b Fh(is)i(similar)h(to)f
+Fe(\(load)23 b(")p Ff(\014lesp)n(e)n(c)n Fe("\))949 2581
+y Fh(10)p eop
+%%Page: 11 11
+11 10 bop 338 311 a Fh(except)18 b(that)e(the)h(name)h
+Fe(load)e Fh(needn't)i(b)q(e)g(b)q(ound)g(in)g(the)f(curren)o(t)h(pac)o
+(k)m(age)338 368 y(to)c(Sc)o(heme's)i Fe(load)e Fh(pro)q(cedure.)338
+457 y Fe(,structure)22 b Ff(name)i(interfac)n(e)338 530
+y Fh(The)15 b Fe(,structure)e Fh(command)h(de\014nes)i
+Ff(name)e Fh(in)h(the)g(con\014guration)g(pac)o(k)m(age)338
+587 y(to)c(b)q(e)i(a)e(structure)h(with)g(in)o(terface)g
+Ff(interfac)n(e)f Fh(based)h(on)g(the)g(curren)o(t)g(pac)o(k)m(age.)338
+676 y Fe(,open)23 b Ff(struct-name)717 660 y Fc(\003)338
+749 y Fh(The)13 b Fe(,open)g Fh(command)g(op)q(ens)h(a)f(new)h
+(structure)f(in)h(the)f(curren)o(t)h(pac)o(k)m(age,)f(as)338
+806 y(if)i(the)h(pac)o(k)m(age's)e(de\014nition's)j Fe(open)e
+Fh(clause)h(had)f(listed)i Ff(struct-name)p Fh(.)224
+926 y Fg(Con\014guration)i(pac)n(k)m(ages)224 1011 y
+Fh(It)c(is)h(p)q(ossible)h(to)e(set)g(up)h(m)o(ultiple)h
+(con\014guration)e(pac)o(k)m(ages.)20 b(The)15 b(default)h(con\014g-)
+224 1068 y(uration)f(pac)o(k)m(age)h(op)q(ens)f(the)h(follo)o(wing)g
+(structures:)292 1151 y Fd(\017)23 b Fe(module-system)p
+Fh(,)11 b(whic)o(h)j(exp)q(orts)f Fe(define-structure)d
+Fh(and)k(the)f(other)f(con-)338 1208 y(\014guration)i(language)g(k)o
+(eyw)o(ords,)e(as)i(w)o(ell)h(as)e(standard)h(t)o(yp)q(es)f(and)h(t)o
+(yp)q(e)g(con-)338 1264 y(structors)g(\()p Fe(:syntax)p
+Fh(,)f Fe(:value)p Fh(,)h Fe(proc)p Fh(,)h(etc.\).)292
+1354 y Fd(\017)23 b Fe(built-in-structures)p Fh(,)18
+b(whic)o(h)j(exp)q(orts)f(structures)f(that)g(are)h(built)i(in)o(to)338
+1410 y(the)10 b(initial)i(Sc)o(heme)f(48)f(image;)h(these)g(include)h
+Fe(scheme)p Fh(,)e Fe(tables)p Fh(,)g(and)g Fe(records)p
+Fh(.)292 1500 y Fd(\017)23 b Fe(more-structures)p Fh(,)12
+b(whic)o(h)j(exp)q(orts)g(additional)g(structures)g(that)e(are)h(a)o(v)
+m(ail-)338 1556 y(able)f(in)g(the)f(dev)o(elopmen)o(t)h(en)o(vironmen)o
+(t;)g(these)f(include)j Fe(sort)p Fh(,)d Fe(random)p
+Fh(,)f(and)338 1613 y Fe(threads)p Fh(.)224 1696 y(Note)k(that)f(it)i
+(do)q(es)f(not)g(op)q(en)h Fe(scheme)p Fh(.)295 1752
+y(Y)l(ou)d(can)f(de\014ne)i(other)e(con\014guration)h(pac)o(k)m(ages)f
+(b)o(y)h(simply)h(making)e(a)h(pac)o(k)m(age)224 1809
+y(that)k(op)q(ens)i Fe(module-system)d Fh(and,)j(optionally)l(,)h
+Fe(built-in-structures)p Fh(,)15 b Fe(more-)224 1865
+y(structures)p Fh(,)f(or)g(other)h(structures)g(that)f(exp)q(ort)h
+(structures)g(and)h(in)o(terfaces.)295 1922 y(F)l(or)e(example:)320
+2005 y Fe(>)23 b(,config)g(\(define-structure)f(foo)h(\(export)g(\))606
+2061 y(\(open)g(module-system)749 2118 y(built-in-structures)749
+2174 y(more-structures\)\))320 2231 y(>)g(,in)h(foo)320
+2287 y(foo>)f(\(define-structure)e(x)j(\(export)f(a)h(b\))487
+2344 y(\(open)f(scheme\))487 2400 y(\(files)g(x\)\))320
+2457 y(foo>)949 2581 y Fh(11)p eop
+%%Page: 12 12
+12 11 bop 338 311 a Fe(,config-package-is)21 b Ff(struct-name)338
+384 y Fh(The)f Fe(,config-package-is)d Fh(command)i(designates)h(a)g
+(new)f(con\014guration)338 441 y(pac)o(k)m(age)10 b(for)f(use)i(b)o(y)f
+(the)g Fe(,config)f Fh(command)h(and)h(resolution)g(of)e
+Ff(struct-name)q Fh(s)338 497 y(for)14 b(other)h(commands)g(suc)o(h)h
+(as)f Fe(,in)f Fh(and)i Fe(,open)p Fh(.)224 617 y Fg(Discussion)224
+702 y Fh(This)j(mo)q(dule)f(system)g(w)o(as)f(not)g(designed)i(as)f
+(the)f(b)q(e-all)j(and)e(end-all)h(of)f(Sc)o(heme)224
+759 y(mo)q(dule)e(systems;)e(it)g(w)o(as)g(only)h(in)o(tended)h(to)e
+(help)i(Ric)o(hard)f(Kelsey)h(and)f(me)f(to)g(or-)224
+815 y(ganize)i(the)f(Sc)o(heme)h(48)f(system.)20 b(Not)14
+b(only)i(do)q(es)g(the)f(mo)q(dule)h(system)f(help)i(a)o(v)o(oid)224
+872 y(name)c(clashes)g(b)o(y)g(k)o(eeping)h(di\013eren)o(t)f
+(subsystems)f(in)i(di\013eren)o(t)f(namespaces,)g(it)g(has)224
+928 y(also)j(help)q(ed)h(us)f(to)f(tigh)o(ten)g(up)h(and)g(generalize)h
+(Sc)o(heme)f(48's)e(in)o(ternal)j(in)o(terfaces.)224
+985 y(Sc)o(heme)c(48)e(is)h(un)o(usual)g(among)f(Lisp)i(implemen)o
+(tations)g(in)g(admitting)f(man)o(y)f(di\013er-)224 1041
+y(en)o(t)16 b(p)q(ossible)i(mo)q(des)f(of)e(op)q(eration.)24
+b(Examples)16 b(of)g(suc)o(h)h(m)o(ultiple)h(mo)q(des)e(include)224
+1098 y(the)f(follo)o(wing:)292 1180 y Fd(\017)23 b Fh(Linking)17
+b(can)e(b)q(e)h(either)g(static)f(or)g(dynamic.)292 1269
+y Fd(\017)23 b Fh(The)h(dev)o(elopmen)o(t)h(en)o(vironmen)o(t)g
+(\(compiler,)i(debugger,)g(and)e(command)338 1325 y(pro)q(cessor\))18
+b(can)h(run)g(either)g(in)h(the)e(same)h(address)g(space)g(as)f(the)h
+(program)338 1382 y(b)q(eing)c(dev)o(elop)q(ed)h(or)e(in)h(a)f
+(di\013eren)o(t)h(address)f(space.)20 b(The)15 b(en)o(vironmen)o(t)f
+(and)338 1438 y(user)g(program)e(ma)o(y)h(ev)o(en)i(run)f(on)f
+(di\013eren)o(t)h(pro)q(cessors)g(under)g(di\013eren)o(t)g(op-)338
+1495 y(erating)h(systems[5)o(].)292 1584 y Fd(\017)23
+b Fh(The)18 b(virtual)g(mac)o(hine)h(can)f(b)q(e)h(supp)q(orted)f(b)o
+(y)g(either)g(of)g(t)o(w)o(o)e(implemen)o(ta-)338 1640
+y(tions)f(of)g(its)g(implemen)o(tation)i(language,)e(Presc)o(heme.)224
+1723 y(The)e(mo)q(dule)g(system)f(has)g(b)q(een)h(helpful)i(in)e
+(organizing)g(these)f(m)o(ultiple)i(mo)q(des.)19 b(By)224
+1779 y(forcing)g(us)f(to)g(write)g(do)o(wn)g(in)o(terfaces)h(and)g(mo)q
+(dule)g(dep)q(endencies,)j(the)c(mo)q(dule)224 1836 y(system)12
+b(helps)i(us)e(to)g(k)o(eep)h(the)f(system)g(clean,)h(or)f(at)g(least)g
+(to)g(k)o(eep)h(us)f(honest)h(ab)q(out)224 1892 y(ho)o(w)i(clean)h(or)f
+(not)g(it)g(is.)295 1949 y(The)f(need)h(to)f(mak)o(e)g(structures)g
+(and)g(in)o(terfaces)h(second-class)g(instead)g(of)f(\014rst-)224
+2005 y(class)19 b(results)f(from)g(the)g(requiremen)o(ts)h(of)e(static)
+h(program)f(analysis:)27 b(it)18 b(m)o(ust)g(b)q(e)224
+2061 y(p)q(ossible)h(for)c(the)i(compiler)h(and)f(link)o(er)h(to)e
+(expand)h(macros)f(and)g(resolv)o(e)h(v)m(ariable)224
+2118 y(bindings)12 b(b)q(efore)f(the)f(program)f(is)i(executed.)19
+b(Structures)11 b(could)g(b)q(e)g(made)f(\014rst-class)224
+2174 y(\(as)15 b(in)i(FX[6)o(]\))e(if)i(a)e(t)o(yp)q(e)h(system)g(w)o
+(ere)g(added)g(to)f(Sc)o(heme)i(and)f(the)g(de\014nitions)i(of)224
+2231 y(exp)q(orted)d(macros)e(w)o(ere)h(de\014ned)i(in)f(in)o(terfaces)
+f(instead)h(of)f(in)h(mo)q(dule)g(b)q(o)q(dies,)g(but)224
+2287 y(ev)o(en)h(in)g(that)e(case)h(t)o(yp)q(es)h(and)f(in)o(terfaces)g
+(w)o(ould)h(remain)g(second-class.)295 2344 y(The)e(prohibition)i(on)e
+(assignmen)o(t)f(to)h(imp)q(orted)g(bindings)i(mak)o(es)e(substitution)
+224 2400 y(a)g(v)m(alid)i(optimization)f(when)f(a)g(mo)q(dule)h(is)g
+(compiled)h(as)d(a)h(blo)q(c)o(k.)20 b(The)15 b(blo)q(c)o(k)g(com-)224
+2457 y(piler)f(\014rst)f(scans)g(the)g(en)o(tire)g(mo)q(dule)h(b)q(o)q
+(dy)l(,)g(noting)f(whic)o(h)h(v)m(ariables)g(are)e(assigned.)949
+2581 y(12)p eop
+%%Page: 13 13
+13 12 bop 224 311 a Fh(Those)14 b(that)g(aren't)f(assigned)i(\(only)g
+Fe(define)p Fh(d\))e(ma)o(y)h(b)q(e)g(assumed)h(nev)o(er)f(assigned,)
+224 368 y(ev)o(en)k(if)g(they)f(are)g(exp)q(orted.)27
+b(The)17 b(optimizer)i(can)e(then)h(p)q(erform)f(a)g(v)o(ery)g(simple-)
+224 424 y(minded)h(analysis)f(to)e(determine)j(automatically)e(that)g
+(some)g(pro)q(cedures)h(can)f(and)224 481 y(should)g(ha)o(v)o(e)f
+(their)h(calls)g(compiled)h(in)f(line.)295 537 y(The)g(programming)g
+(st)o(yle)h(encouraged)g(b)o(y)f(the)h(mo)q(dule)g(system)f(is)h
+(consisten)o(t)224 594 y(with)e(the)g(unextended)h(Sc)o(heme)f
+(language.)20 b(Because)15 b(mo)q(dule)h(system)e(features)h(do)224
+650 y(not)g(generally)i(sho)o(w)e(up)h(within)h(mo)q(dule)f(b)q(o)q
+(dies,)h(an)f(individual)i(mo)q(dule)f(ma)o(y)e(b)q(e)224
+707 y(understo)q(o)q(d)f(b)o(y)f(someone)g(who)g(is)g(not)g(familiar)h
+(with)f(the)g(mo)q(dule)i(system.)j(This)c(is)224 763
+y(a)i(great)e(aid)j(to)e(co)q(de)h(presen)o(tation)g(and)g(p)q
+(ortabilit)o(y)l(.)22 b(If)16 b(a)g(few)f(simple)i(conditions)224
+819 y(are)k(met)f(\(no)g(name)h(con\015icts)h(b)q(et)o(w)o(een)f(pac)o
+(k)m(ages,)h(no)e(use)h(of)g Fe(structure-ref)p Fh(,)224
+876 y(and)g(use)g(of)g Fe(files)f Fh(in)h(preference)h(to)e
+Fe(begin)p Fh(\),)h(then)g(a)g(m)o(ulti-mo)q(dule)i(program)224
+932 y(can)f(b)q(e)h(loaded)g(in)o(to)f(a)f(Sc)o(heme)i(implemen)o
+(tation)g(that)e(do)q(es)i(not)e(supp)q(ort)h(the)224
+989 y(mo)q(dule)17 b(system.)23 b(The)16 b(Sc)o(heme)h(48)e(static)h
+(link)o(er)h(satis\014es)g(these)f(conditions,)h(and)224
+1045 y(can)e(therefore)f(run)h(in)h(other)e(Sc)o(heme)h(implemen)o
+(tations.)21 b(Sc)o(heme)16 b(48's)d(b)q(o)q(otstrap)224
+1102 y(pro)q(cess,)h(whic)o(h)g(is)f(based)h(on)f(the)g(static)g(link)o
+(er,)i(is)f(therefore)e(nonincestuous.)21 b(This)224
+1158 y(con)o(trasts)d(with)i(most)f(other)g(in)o(tegrated)g
+(programming)g(en)o(vironmen)o(ts,)h(suc)o(h)g(as)224
+1215 y(Smalltalk-80,)d(where)g(the)g(system)f(can)g(only)h(b)q(e)g
+(built)h(using)f(an)g(existing)g(v)o(ersion)224 1271
+y(of)e(the)g(system)g(itself.)295 1328 y(Lik)o(e)d(ML)f(mo)q(dules,)h
+(but)g(unlik)o(e)g(Sc)o(heme)g(Xero)o(x)f(mo)q(dules,)h(this)g(mo)q
+(dule)g(system)224 1384 y(is)f(comp)q(ositional.)19 b(That)10
+b(is,)h(structures)f(are)g(constructed)h(b)o(y)f(single)i(syn)o(tactic)
+e(units)224 1440 y(that)i(comp)q(ose)h(existing)h(structures)e(with)h
+(a)g(b)q(o)q(dy)g(of)g(co)q(de.)19 b(In)14 b(Sc)o(heme)f(Xero)o(x,)f
+(the)224 1497 y(set)21 b(of)g(mo)q(dules)h(that)f(can)g(con)o(tribute)g
+(to)g(an)g(in)o(terface)g(is)h(op)q(en-ended)h(|)f(an)o(y)224
+1553 y(mo)q(dule)f(can)f(con)o(tribute)g(bindings)i(to)d(an)o(y)g(in)o
+(terface)h(whose)g(name)g(is)g(in)g(scop)q(e.)224 1610
+y(The)c(mo)q(dule)g(system)g(implemen)o(tation)g(is)g(a)f(cross-bar)g
+(that)g(c)o(hannels)i(de\014nitions)224 1666 y(from)e(mo)q(dules)h(to)f
+(in)o(terfaces.)21 b(The)16 b(mo)q(dule)h(system)e(describ)q(ed)i(here)
+f(has)f(simpler)224 1723 y(seman)o(tics)g(and)f(mak)o(es)g(dep)q
+(endencies)j(easier)e(to)f(trace.)19 b(It)14 b(also)g(allo)o(ws)h(for)f
+(higher-)224 1779 y(order)h(mo)q(dules,)h(whic)o(h)g(Sc)o(heme)g(Xero)o
+(x)f(considers)h(unimp)q(ortan)o(t.)224 1922 y Fi(References)247
+2024 y Fh([1])22 b(William)c(Clinger)g(and)e(Jonathan)h(Rees.)25
+b(Macros)15 b(that)h(w)o(ork.)23 b Ff(Principles)16 b(of)318
+2080 y(Pr)n(o)n(gr)n(amming)f(L)n(anguages)p Fh(,)f(Jan)o(uary)h(1991.)
+247 2174 y([2])22 b(William)12 b(Clinger)g(and)f(Jonathan)f(Rees)i
+(\(editors\).)g(Revised)1370 2158 y Fb(4)1402 2174 y
+Fh(rep)q(ort)f(on)f(the)h(al-)318 2231 y(gorithmic)g(language)h(Sc)o
+(heme.)i Ff(LISP)d(Pointers)g Fh(IV\(3\):1{55,)e(July-Septem)o(b)q(er)
+318 2287 y(1991.)247 2381 y([3])22 b(P)o(a)o(v)o(el)17
+b(Curtis)h(and)g(James)g(Rauen.)29 b(A)18 b(mo)q(dule)h(system)f(for)f
+(Sc)o(heme.)29 b Ff(A)o(CM)318 2437 y(Confer)n(enc)n(e)14
+b(on)i(Lisp)f(and)i(F)m(unctional)e(Pr)n(o)n(gr)n(amming,)f
+Fh(pages)h(13{19,)e(1990.)949 2581 y(13)p eop
+%%Page: 14 14
+14 13 bop 247 311 a Fh([4])22 b(Da)o(vid)11 b(MacQueen.)k(Mo)q(dules)e
+(for)e(Standard)h(ML.)i Ff(A)o(CM)e(Confer)n(enc)n(e)f(on)i(Lisp)318
+368 y(and)j(F)m(unctional)f(Pr)n(o)n(gr)n(amming,)f Fh(1984.)247
+462 y([5])22 b(Jonathan)16 b(Rees)h(and)f(Bruce)h(Donald.)23
+b(Program)14 b(mobile)k(rob)q(ots)d(in)i(Sc)o(heme.)318
+518 y Ff(International)e(Confer)n(enc)n(e)f(on)i(R)n(ob)n(otics)g(and)g
+(A)o(utomation,)f Fh(IEEE,)g(1992.)247 612 y([6])22 b(Mark)10
+b(A.)h(Sheldon)h(and)g(Da)o(vid)f(K.)g(Gi\013ord.)i(Static)e(dep)q
+(enden)o(t)i(t)o(yp)q(es)e(for)g(\014rst-)318 668 y(class)i(mo)q
+(dules.)18 b Ff(A)o(CM)13 b(Confer)n(enc)n(e)f(on)i(Lisp)g(and)g(F)m
+(unctional)f(Pr)n(o)n(gr)n(amming,)318 725 y Fh(pages)i(20{29,)e(1990.)
+949 2581 y(14)p eop
+%%Trailer
+end
+userdict /end-hook known{end-hook}if
+%%EOF
diff --git a/doc/news.txt b/doc/news.txt
new file mode 100644
index 0000000..c8eb269
--- /dev/null
+++ b/doc/news.txt
@@ -0,0 +1,700 @@
+-*- Mode: Indented-text; -*-
+
+Recent changes to Scheme 48.
+
+2/24/99  (version 0.53)
+	 Additions:
+	  DEFINE-FINITE-TYPE and DEFINE-ENUMERATED-TYPE (in structure
+	   FINITE-TYPES; documented in doc/utilities.ps and
+	   doc/html/utilities.html.
+          Added CHAR-SOURCE->INPUT-PORT, CHAR-SINK->OUTPUT-PORT,
+ 	   MAKE-STRING-OUTPUT-PORT, STRING-OUTPUT-SOURCE-OUTPUT to
+	   the extended-ports structure.
+	  The structure BYTE-VECTORS is the same as CODE-VECTORS with `byte'
+	   replacing `code' in all the names.  The underlying datatype is the
+	   same for both, and uses `byte' when printing.
+	  There is a new and much improved interface to C code, thanks to
+           Mike Sperber.  It is documented in in doc/external.ps and
+	   doc/html/external.html.
+         Bug fixes:
+	  Session-data and user-context records are no longer in the fluid env.
+	  Lexical environments can now be nested up to 65k deep.
+	  ,expand no longer prints `definition in expression context' warnings.
+	  Added ARRAY? and SEARCH-TREE? to the array and search tree structures.
+	  Flat environments work again.
+	  Templates of the form `var ... ...' now work in syntax rules.
+	  Reinstated caching of SCHEMIFY results to greatly reduce the space
+           used by debugging info.
+	  Added argument checking to STRING->NUMBER and NUMBER->STRING.
+	  Fixed space blow-up in LOAD.
+	  Unused ports are closed more reliably.
+	 Changes:
+	  The heap, gc, and image code is now in three separate modules.
+          The symbol table is now held in a VM register.
+	  Inlined SHOWING-FOCUS-VALUES into the main command loop and moved
+	   the sentinal call to reduce the noise at the base of ,preview output.
+	  The tables returned by MAKE-TABLE now use EQV? for comparison (instead
+	   of EQ?).  This makes these tables about 50% slower when numbers are
+           used as keys, but significantly more accurate.
+	  Floating-point numbers are no longer double boxed.
+	  The channels structure has been split into channels and low-channels.
+
+7/22/98  (version 0.52)
+         Bug fixes:
+	  Fixed problems with unbound variables in SET! and the inliner.
+	  Made macro expansion a bit less eager; this should reduce the amount
+           of heap space needed for compilation.
+
+6/29/98  (version 0.51)
+	 Incompatible changes:
+          BIG-SCHEME no longer exports its version of DEFINE-RECORD-TYPE (but
+	   it is available from the structure DEFRECORD).  I am slowly removing
+           all uses of this version of DEFINE-RECORD-TYPE from the sources.
+	  The version of DEFINE-RECORD-TYPE exported by DEFINE-RECORD-TYPES
+	   checks that every constructor argument corresponds to a field.
+	  Uses of LAP must list their free variables (see env/assem.scm).
+	 Changes:
+	  The functions exported by BIG-SCHEME that were not available elsewhere
+	   are now exported by BIG-UTIL as well.
+          MAKE-RANDOM now checks its argument (but is still a fairly poor
+           source of pseudo-randomness).
+	  SIGPIPE no longer kills the S48 process (this was done earlier but
+	   not listed here).
+	  The macro/module/compiler code has been reorganized.  Hopefully
+	   the only noticable difference is in the babble written when loading
+           files and packages.
+	  Added CODE-QUOTE (in its own structure of the same name) for use
+           in writing hygienic macro-generating macros.  CODE-QUOTE is the
+           same as QUOTE except that it does not strip off any of the macro
+	   system's name annotations.
+	  The FLOATNUMS package now exports FLOATNUM?.
+	 Bug fixes:
+	  Fixed phony stack-overflow bug.
+	  Fixed a bug in thread time-debit mechanism.
+	  Made floating point numbers always print as inexact.
+	  Got rid of bogus type-error warnings when using floatnums.
+	  Fixed declaration of call_startup_procedure in c/main.c.
+
+2/11/98  (version 0.50)
+         Fixed bug in closed-compiled version of READ-CHAR.
+	 Fixed negative-key bug in integer tables.
+
+11/18/97 (version 0.49)
+	 Removed some non-portable Kali code that had been accidentally
+	  included in c/extension.c.
+
+10/29/97 (version 0.48)
+         The VM's calling convention now has the caller doing protocol checking,
+	  instead of the callee.  The *NARGS* register no longer exists.
+	 Scheme's variable-arity procedures (APPLY, MAKE-VECTOR, +, -, etc.)
+	  are usually handled without raising an exception.  Calls with an
+	  `atypical' number of arguments are now much faster.
+	 Opcodes were added for >, <=, and >=.
+	 Procedures can take up to about 8k arguments.  The limit is determined
+	  by the value of AVAILABLE-STACK-SPACE in scheme/vm/arch.scm.
+         Compiler detects wrong number of arguments in ((lambda ...) ...).
+	 Removed the dynamic point from the dynamic environment to make
+          DYNAMIC-WIND behave reasonably with threads.
+	 KILL-THREAD! should work more reliably.
+	 The I/O primitives now pass OS error messages to the exception handlers.
+	 I/O errors when flushing buffers no longer crash the system.
+	 The Pre-Scheme compiler's hack for shadowing global variables with
+	  local copies is no longer used.
+	 Incompatible changes:
+	  The internal thread interface was simplified.
+	  There are some architecture changes; .image files will have to
+	   be rebuilt.
+          ACCESS-SCHEME-48 and scheme/misc/slib-init.scm have been removed
+	   (thanks to Mike Sperber's updating of slib).
+
+1/27/97	 (version 0.47)
+	 Fixed ,exit and added ,exit-when-done.
+	 CASE now uses EQV? exclusively.
+
+11/5/96	 (version 0.46)
+	 Fixed a few minor thread problems.
+         opt/analyze.scm now writes to current-noise-port.
+         DELQ and DELETE now delete every instance, as the documentation claims.
+	 There should be no more spurious heap-overflow interrupts.
+	 Fixed bugs that caused the system to die if stdout blocked.
+	 Template offsets have been increased to two bytes.
+	 Disassembly of flat-lambda now works (fix from Michael Sperber).
+
+8/23/96	 (version 0.45)
+	 Fixed various problems with thread termination and nested schedulers.
+	 Changed thread-internal interface to make schedulers easier to write.
+	 BITWISE-{AND,IOR,XOR} now take an arbitrary number of arguments.
+	 Output ports have their buffers flushed when Scheme 48 terminates.
+	 In keeping with RnRS, CLOSE-{IN,OUT}PUT-PORT are now idempotent.
+	 MODULO now handles negative arguments properly.
+
+6/20/96  (version 0.44)
+	 The VM's byte-code interpreter and storage management code are
+	  now compiled to separate C files.
+	 The socket code works again.
+
+5/10/96  (version 0.42-0.43)
+	 Various fixes to the thread and I/O systems.
+	 The Unix interface code is more portable.
+         EOF (control-D) now resumes running all non-broken threads on
+	  resumed command level.  Thus EOF after a keyboard interrupt
+	  (control-C) resumes running the interrupted thread.
+	 
+11/30/95 (version 0.41)
+         The distribution has been reorganized to reduce the number of files
+	  in the top-level directory.
+	 The threads implementation has been replaced with one based on engines
+	  to allow for nested schedulers.
+         Threads are now included in the initial image.
+         The I/O system has been fixed and automatic periodic output buffer
+	  flushing has been reinstalled.
+	 Command levels have been integrated with the threads system to ensure
+          that at most one REPL is active at any time.
+	 CONDVAR has been changed to PLACEHOLDER (condition variables being
+	  something quite different).
+	 ,profile no longer works, it will be fixed in a later version.
+         MIN and MAX now do inexact contagion.
+
+4/13/95  (version 0.40)
+	 Renamed error-output-port to current-error-port.
+	 Reinstated ".gdbinit"...
+	 segment->template now takes parent templates debug data as an
+	   argument.
+	 Automatic periodic output buffer flushing has been
+	   temporarily disabled.  A future version of the I/O system
+	   will fix it.
+	 Fixed expansion of named LET.
+	 The bummed-define-record-types structure is now gone; use
+	   define-record-types instead.
+	 There is somewhat better syntax checking now.
+
+8/12/94  (versions 0.38-0.39)
+         ,profile <command> prints out profiling information
+         An interrupt is raised after ever GC; the default handler checks
+           to see if some reasonable amount of storage was reclaimed.
+         Some of the standard Scheme procedures, including LENGTH, FOR-EACH,
+           VECTOR, and ASSQ, are now significantly faster.
+	 Making, accessing, and setting records is faster.
+         tar file now includes the top-level directory
+         The "scheme-level-2-internal" structure has been renamed to
+           "usual-resumer".
+         ` ( . ' is now illegal (as required by the R4RS grammar).
+	 Made DELAY and FORCE comply with R4RS.
+         The EXPAND optimizer does a topological sort on definitions.
+         (optimize flat-environments) causes the compiler to produce
+           flat (instead of nested) lexical environments.
+         The I/O system has been rewritten to do its own buffering.  There
+           are significant changes to unix.c to support this.  See doc/io.txt.
+         (ERROR-OUTPUT) is now available from the structure i/o.
+	 jar-defrecord has been replaced with a modified bummed-jar-defrecord
+         Files load about 25% faster, for a number of reasons.
+	 Removed the copy of vm/arch.scm from the rts directory.
+	 Threads and sockets work together; SOCKET-ACCEPT no longer blocks.
+         The compiler no longer prints out .'s as it compiles definitions.
+
+7/5/94   (version 0.37)
+         I/O opcodes now raise an interrupt instead of blocking (they still
+           block if no corresponding interrupt handler has been installed).
+         The threads code has been rewritten; threads that block on I/O
+           do not busy wait and THREAD-READ-CHAR and THREAD-PEEK-CHAR have
+           been removed.
+         Attempting to obtain a lock twice or to release an unowned lock
+           now signal errors.
+	 READ-CHAR-WITH-TIMEOUT returns #F if the timeout occurs.
+         The socket structure is back in more-packages.scm.
+         Renamed .gdbinit to gdbinit
+	 tar file now contains a top-level directory
+
+3/22/94  (version 0.36)
+         Removed doc/lsc.ps for copyright reasons.
+         Fixed (* 47123 46039) multiply bug.
+         Modified vm/README to make it easier to run the VM.
+
+3/16/94  (version 0.35)
+	 Fixed (exact->inexact 0.1) -> 0..1. bug.
+         Fixed VM bug that permitted the creation of stored objects with
+	   negative sizes.
+
+3/8/94   (version 0.34)
+	 "make check" target tests out various features.
+	 Fixes for SGI IRIX 4.0.5 and MIPS RISC/OS 4.51, courtesy
+	   Bryan O'Sullivan.
+	 debug/run.scm and the "medium system" work again now.
+	 misc/static.scm should work on the 68000.
+	 Command processor no longer fluid-binds (interaction-environment)
+	   on recursive entry.
+
+2/24/94  (version 0.33)
+	 Fixed bug in VM's interrupt system.
+	 Made non-local srcdir work in Makefile.
+	 Added (load-package 'bigbit) to vm/README.
+
+2/23/94  (version 0.32)
+	 Some incompatible changes to the VM; .image files will have
+	   to be rebuilt.
+	 Improvements to configuration script and to unix.c to support
+	   a wider variety of Unixes.  The system should now work
+	   under any Posix-compliant Unix (except maybe for
+	   char-ready?; see comments in unix.c).
+	 Upped the default heap size from 4 meg (2 per semispace) to 6
+	   meg (3 per semispace).
+	 New command line argument -s <size> for specifying size of
+	   stack buffer.  Default is 2500 (words).
+         $@ -> "$@" in script (thanks to Paul Stodghill for this fix).
+	 Obscure interrupt/exception VM bug fixed.
+	 It is now possible to put an initial heap image into static
+	   memory (effectively allocated by OS process creation).
+	   Immutable initial objects go into static read-only memory,
+	   and mutable initial objects go into static read-write
+	   memory.  Initial objects not copied by the GC.  There is no
+	   documentation yet, but look at the rules for little and
+	   debug/little.o in the Makefile if you're interested.
+
+2/13/94  (version 0.31)
+	 Incompatible changes:
+	   In interfaces, all exported syntactic keywords must be
+	     given type :syntax.  For example,
+	       (define-interface my-macros
+	         (export (my-macro :syntax) ...))
+	   Image entry procedures for the ,build command are now
+	     passed a list of strings, not just a single string, for
+	     the command line arguments following -a.
+	   The names of the macros defined in scheme48.h
+	     (pairp, car, string_length, etc.) are now all upper case.
+	 New "configure" script generates Makefile from Makefile.in
+	   and sysdep.h from sysdep.h.in (thanks to Gnu autoconf).
+	   See INSTALL and doc/install.txt.
+	 Bug fixes:
+           Can now make vectors (strings, etc.) as big as the amount
+             of heap space available (but you're still screwed if you
+             try to make one bigger than 2^23-1 bytes - don't do it).
+	   Non-ANSI-ness fixed in scheme48vm.c (jump out of, then
+	     back into, a block expected block-local variables to be
+	     unchanged).
+	   Fixed big/external.scm (had VECTOR-POSQ instead of ENUM).
+	   In (define-syntax foo bar) you got an error if bar was a
+	     variable reference.
+	   Plugged a storage leak (file-environments table in
+	     env/debug.scm).  Images made with ,build were too large.
+	   Flushed extraneous delay from make-reflective-tower.
+	 Renamed variables in Makefile to resemble Gnu standards.
+	 Fixed definition of LINKER_RUNNABLE in Makefile.
+	 Added doc/call-back.txt.
+	 Fixed define-enumerated documentation (doc/big-scheme.txt).
+	 Environment maps no longer retained for things in initial.image
+	   and scheme48.image.  This makes scheme48.image about 170K
+	   smaller.
+
+2/3/94   (version 0.30)
+	 Faster EXPT.
+	 FLOATNUMS improvement: (inexact->exact <float>) should now
+	   work, e.g. 
+           (inexact->exact (/ 1. 3.)) => 6004799503160661/18014398509481984
+         Reinstated ACCESS-SCHEME-48 for the benefit of PSD (portable
+           scheme debugger) and a certain other software package that
+           shall remain nameless.  It only knows about a small number of
+           procedures, including things like ERROR and FORCE-OUTPUT.
+         Various changes to support the Pre-Scheme compiler, notably
+	   SET-REFLECTIVE-TOWER-MAKER!.
+	 Incompatible change to the ENUMERATED structure: the names
+	   foo/bar no longer become defined.  Write (enum foo bar)
+	   instead.  This will macro expand into the correct small
+	   integer.
+
+1/30/94  (version 0.29)
+	 Fixed ps_run_time() to call sysconf() to find out how many
+	   ticks there are per second.  It used to assume 60.  This
+	   affects the output of the ,time command, so don't try
+	   comparing numbers from this version with numbers from older
+	   versions.
+	 ,time command will now accept a command, e.g.
+	   ,time ,load foo.scm.
+	 It appears that if multiple arguments follow -a on the
+	   argument line, they are concatenated together with spaces
+	   separating them and passed to the startup procedure.  I
+	   don't know how long this has worked.  This will change in
+	   the future so that the startup procedure gets a list of
+	   strings.
+	 Installed what used to be called the GENERAL-TABLES structure
+	   as the TABLES structure used by the system.  This allows
+	   the use of other comparison predicates besides EQ?, and
+	   eliminates some code that had a restrictive copyright
+	   notice.
+         ENUM, NAME->ENUMERAND, and ENUMERAND->NAME are all macros.
+         Enumerated types themselves are now macros as well.
+
+1/23/94  Fixed bad multiplication bug in VM: (* 214760876 10) was
+	   returning 125112.
+	 Moved RECORD-TYPE? and RECORD-TYPE-FIELD-NAMES from the
+	   RECORDS-INTERNAL interface to the RECORDS interface, for
+	   a somewhat closer approximation to MIT Scheme.
+         Various type system improvements.
+	 Still no documentation for the ,exec package, but see
+	   link/load-linker.exec for an example.
+	 New generic function feature, exported by the METHODS
+	   interface (see interfaces.scm), almost like in a certain
+	   dynamic object-oriented language.
+
+1/11/94  (version 0.27)
+	 Change:
+	   The isomorphism used by CHAR->INTEGER and INTEGER->CHAR is
+	     no longer ASCII.  This change was introduced in order to
+	     assist the development of portable programs.  If you need
+	     ASCII encoding, you should open the ASCII structure and
+	     use the procedures CHAR->ASCII and ASCII->CHAR.
+         Features:
+	   The help system is somewhat improved.
+	   New form DEFINE-STRUCTURE defines a single structure.
+	 Incompatible changes to package system:
+	   Renamed DEFINE-PACKAGE to DEFINE-STRUCTURES
+	   Renamed DEFINE-STRUCTURE to DEFINE
+	   Renamed all the base types from FOO to :FOO.  E.g.
+	     :SYNTAX, :VALUE, :PAIR, etc.
+         Other:
+	   Removed socket support due to restrictive copyright on some
+	     of the C code that was in extension.c.
+
+12/21/93 ,take has been flushed in favor of ,exec ,load.  Commands are
+	   now accessed via a distinguished package instead of a table.
+	   Documentation pending.
+         Postscript (.ps) files now included in doc/ subdirectory.  (I
+           thought they had been there all along, but apparently I was
+           wrong.)
+         Enhanced, but still kludgey, floating point support.  Use
+	   ,open floatnum.
+
+12/12/93 (version 0.26)
+	 NetBSD port.
+	 Hacked write-level and write-depth for inspecting circular
+	   structure.
+	 Recursive FORCEs signal errors, e.g.
+	   (force (letrec ((loser (delay (force loser)))) loser))
+
+12/7/93 (version 0.25)
+         Bug fix:
+	   filenames.make can now be remade using initial.image.  This
+	     means that you can snarf a distribution and then edit
+	     USUAL-FEATURES before making scheme48.image.
+
+
+12/6/93  Incompatible changes:
+	   Change of terminology: "signature" --> "interface".
+	     This means that DEFINE-SIGNATURE is now called
+	     DEFINE-INTERFACE, etc.
+           Some structures have been renamed:
+	     condition -> conditions
+	     continuation -> continuations
+	     exception -> exceptions
+	     queue -> queues
+	     port -> ports
+	     record -> records, record-internal -> records-internal
+	     table -> tables
+	     template -> templates
+	   The ,load-into command has been removed.  Use ,in ... ,load
+	     instead (see below), e.g.
+	       ,in mumble ,load myfile.scm
+           The heap size for -h is specified in words, not bytes.  As
+	     before, the size must account for both semispaces; -h 2n
+	     means n words per semispace.  This change was actually
+	     made a while ago, but I was confused as to what it meant.
+         Bug fixes:
+	   #e1.7 reads as 17/10, (exact? 1+1.0i) => #f, and 1.0+i prints.
+         Features:
+	   Things like ((structure-ref scheme if) 1 2 3) work.
+	   The following commands now take arbitrary commands to execute
+	     in the specified package, not just forms:
+	       ,config   ,user   ,for-syntax   ,in <package>
+             For example, you can say
+	       ,in mumble ,trace foo
+             This subsumes the functionality of the ,load-into and
+	     ,load-config commands.
+           Dynamic loading of shared libraries for System V systems
+	     (untested).
+         Documentation:
+	   Somewhat improved.  user-guide.txt now lists most of the
+	   interesting built-in packages.  lsc.ps is a draft of "A
+	   Tractable Scheme Implementation," a paper submitted to Lisp
+	   and Symbolic Computation.  See also doc/big-scheme.txt,
+	   doc/thread.txt, and doc/external.txt.
+
+
+10/30/93 LET-SYNTAX and LETREC-SYNTAX.
+	 Arrays (see big/array.scm).
+	 Lots of internal changes.
+
+7/20/93  Features:
+	   Type system.  See doc/types.txt.
+
+7/4/93   Features:
+           New define-package clause (for-syntax <clause>*).
+	     E.g. (define-package ((my-package ...))
+		    (open ...)
+		    (for-syntax (open scheme my-utilities)
+			        (files more-crud-for-syntax))
+                    ...)
+           A file name to package map is now used by the emacs
+	     interface.  Whenever you load a file, or zap from a file that
+	     hasn't been previously loaded or zapped, the package in
+	     which forms are being evaluated is remembered in a table.
+	     The next time you zap some forms from the same file, they
+	     will be evaluated in that package.
+	     Sometimes you may get an association you don't want.  In that
+	     situation, you can use the ,forget command to delete an
+	     entry in the table.
+           A new ,push command goes to a deeper command level.
+	   Experimental "command preferred" command processor mode: if
+	     you give the command ",form-preferred off", commands will
+	     be "preferred" to forms, meaning that you don't need to
+	     type a comma before giving a command.  To see the value
+	     of a variable FOO you have to say (begin foo).
+           Experimental "no levels" command processor mode: if you
+	     give the command ",levels off", then an error will not
+	     push a new command level.  If you want to ignore an
+	     error, you don't need to take any action - further
+	     evaluations will happen at top level.  If you want to
+	     enter the inspector or get a preview, you can issue these
+	     commands or a ,push command immediately after the error
+	     occurs (more precisely, any time until the focus object
+	     is set by some other command).
+	   All of the mode-control commands (batch, bench,
+	     break-on-warnings, form-preferred, and levels) take
+	     an optional argument.  When no argument is given, they
+	     will toggle the corresponding mode.  With an argument of
+	     ON or OFF, they turn the mode on or off.
+           The ,flush and ,keep commands have been made more flexible
+	     and verbose.
+
+
+6/18/93  Incompatible changes:
+	   The access-scheme48 procedure has gone away.  Use ,open
+	     or the module system instead.
+           The user, configuration, and for-syntax packages no longer
+	     have variables bound to them in the configuration package.
+	     Where previously you said:       Now you should say:
+	      ,in user <form>                  ,user <form>
+	      ,in config <form>                ,config <form>
+	      ,in for-syntax <form>            ,for-syntax <form>
+	      ,load-into config <file>         ,load-config <file>
+	      ,load-into for-syntax <file>     ,for-syntax (load "file")
+
+	 Features:
+           There is an ,expand <form> command for debugging macros.
+	   The ,open  command takes any number of structure names, and opens
+	     them all (like ,new-package).
+	   New procedure DEFINE-INDENTATION exported by the PP structure.
+	     E.g. (define-indentation 'let-fluid 1) is like Gnu emacs's
+	     (put 'let-fluid 'scheme-indent-hook 1).
+           The inspector simplifies generated names in continuation
+	     source code display.  E.g. when formerly it said
+	       "Waiting for (#{Generated lambda} () (x->node (car exps)))"
+	     now it says 
+	       "Waiting for (lambda () (x->node (car exps)))"
+           Macros can signal syntax errors by returning input expression
+	     unchanged.  (Comparison uses EQ?.)
+
+         Documentation:
+	   The doc/ directory contains a draft of a "Scheme 48
+	     Progress Report."
+
+         Cleanup:
+	   Procedure NULL-TERMINATE added to structure EXTERNALS's
+	     signature.
+	   "Vulgar Scheme" renamed to "Big Scheme".
+	   Two new subdirectories, env/ (for programming environment)
+	     and big/ (for Big Scheme), now contain most of what was
+	     in the misc/ directory.
+           Several source files that were in the top level and link/
+	     directories have moved to the env/ and alt/ directories.
+
+
+5/6/93   Bug fixes:
+	   Fixed -h command line switch.  The size was being improperly
+	     divided by 4, so if you asked for an N megabyte heap, you'd
+	     actually only get an N/4 megabyte heap.
+	   Nested backquotes were broken for a while; should be fixed
+	     now.
+
+         Features:
+	   Quoted structure is read-only: e.g. (set-car! '(a b) 3) will
+	     produce an exception.
+	   ,config [<form>] and ,user [<form>] are like ,in <struct> <form>.
+	   Unix socket support; see misc/socket.scm.
+	   Now using gzip instead of compress for distributions.
+	   ,open command offers to load packages.
+	   A .gdbinit file sets a breakpoint at CM's exception raising
+	     code, and defines a handy "preview" command.
+
+1/18/93  Feature:
+           Scheme 48 distributions now have version numbers.  The
+	     version number is printed in the image startup message.
+	     Please include it in bug reports.
+         The module system is now documented.  See doc/module.tex.
+
+12/17/92 Bug fixes:
+           Macro templates of the form (x ... y) are supported.
+	   Macro templates are now less fussy about meta-variable
+	     rank: you can do "(x y) ..." even when the rank of either
+	     x or y (but not both) is too low; the low-ranking text
+	     will be copied as many times as necessary.  (A
+	     meta-variable's "rank" is the number of ...'s it sits
+	     under in the left-hand side of the rewrite rule.)
+	   SYNTAX-RULES is now itself hygienic.  This means you can
+	     have a meta-variable named CAR, for instance.
+
+         New development environment features:
+	   Commands now start with comma (",") instead of colon
+	     (":").  (Easier to type since it's not shifted.)
+	   values, call-with-values, dynamic-wind, eval,
+	     interaction-environment, and scheme-report-environment
+	     added per upcoming Revised^5 Scheme report.  See
+	     doc/meeting.tex.
+	   Modifications to quoted structure will now be detected and
+	     reported as errors.
+	   An interrupt will occur if an insufficient amount of memory
+	     is reclaimed by a garbage collection.
+	   Inspector now accepts arbitrary command processor commands
+	     (with or without leading comma)
+           ,keep command controls retention of debugging information.
+
+	 Features removed:
+	   #\page and #\tab.  These aren't in the Scheme report.
+	     Their absence in Scheme 48 will encourage portability.
+	   access-scheme48 works with fewer names than before.  Use the
+	     package system instead.
+           Complex numbers not in the system, by default.  Get them
+	     back by changing usual-features in more-packages.scm.
+
+	 Features changed:
+	   Many changes to package system.  See doc/module.tex.
+           The :identify-image command is gone.  Instead, supply a
+	     second argument (optional) to the ,dump command.
+	   The inspector's TEM command has been shortened to T.
+
+         Internal changes and features:
+	   Stored objects types are now part of the virtual machine
+	     architecture, i.e. known to the byte-code compiler.
+	   Run-time system is split up into many little modules.
+	   File names are retained in debug database.  (But not used for
+	     anything yet...)
+	   Tweaks to table package reduce standard image size by 50K
+	     and increase compiler speed by 7%.
+	   Immutability bit in object headers.
+	   Weak pointers.
+
+7/18/92  Features removed:
+	   Table package's default hash function no longer supports
+	     string, pairs, or vectors.
+
+7/9/92   Bug fixes:
+	   (- 0 -536870912)
+	   Inspector now uses command i/o ports instead of current ones
+	   Inexact integers print as N. instead of #iN
+	   Throwing back into a call-with-....put-port now produces a
+	     warning instead of an error
+
+	 Feature fixes:
+	   In DEFINE-PACKAGE, OPEN no longer implies ACCESS.
+	   misc/receive.scm renamed to rts/values.scm, made to conform
+	     with Revised^5 Report, and installed internally.
+
+	 Features:
+	   New :load-package command.  Uses file names in (file ...) clause
+	     of a define-package.  These are interpreted relative to the
+	     directory in which the file containing the define-package
+	     was found.
+	   #\tab and #\page now print this way.
+
+
+6/17/92  Bug fixes:
+	   Fixed bug in modulo.
+	   Flushed LAST-PAIR (which disappeared between R^3 and R^4).
+	   DEFINE-SYNTAX and SYNTAX-RULES now exist.
+	   CEILING, FLOOR, and ROUND now exist.
+	   GCD and LCM are now n-ary.
+	   STRING-CI=? and STRING-COPY fixed.
+	   STRING->SYMBOL now copies its argument before handing it to
+	     INTERN.
+	   =, <, etc. now work with more than two arguments.
+	   CHAR-READY? exists.
+	   Calls via APPLY are now tail-recursive.
+	   DISPLAY of vectors and lists works (ugh).
+
+	 Development environment improvements:
+	   Type ? at inspector to get list of inspector commands.
+	   Inspector D command goes to next continuation.
+	   Inspector M command shows more of a long menu.
+	   Inspector TEM command goes to a continuation's or closure's
+	     template.
+	   For closures and continuations, inspector displays local
+	     variables with their names. 
+	   For continuations, inspector displays source code for
+	     expression into which control will return.
+	   Multiple command loop levels.  EOF (control-D) now only pops
+	     out a single level.  :reset pops all the way out.  :level n
+	     goes out to level n.
+	   Can disable benchmark mode.
+	   Procedures made with (let ((f (lambda ...))) ...) now print
+	     with names.
+
+	 Features:
+	   Package system: special forms define-package and package-ref;
+	     command processor commands :set-package, :load-into,
+	     :clear-package, :new-package, :export, :open-package, etc.
+	   In misc directory: threads, queues, extended ports, format, etc.
+
+	 Changes to system environment:
+	   user-initial-environment -> user-package
+	   record-updator -> record-modifier
+	   primitive-throw superseded by with-continuation
+	   ash -> arithmetic-shift
+	   New bootstrap regime.
+	   Support for threads: alarm clock interrupt, etc.
+
+	 Etc.:
+	   Liberal COPYRIGHT file, and a little notice in each source file.
+	   INSTALL and NEWS split off from README.
+	   doc.txt renamed to user-guide.txt.
+	   The Makefile now provides two ways to make "s48" for
+	     installation.  One depends on the exec #! script execution
+	     feature and the other doesn't.
+	   "make" targets for testsys.image and little.image.
+	   Runs Jaffer's test suite and library.
+	   Flushed s48.el.  Use cmuscheme instead.
+
+
+9/5/90   Command processor argument parser revamped.
+	 :load, :trace, and :untrace commands take arbitrary number
+	   of arguments.  Argument to :proceed is optional.
+	 New (but undocumented) :identify-image command.
+	 Better error messages: wrong number of arguments, undefined
+	   variable.
+	 +, *, min, max, apply are now n-ary; -, /, make-string,
+	   make-vector, read-char, peek-char, write-char have
+	   appropriate argument optionality.
+	 Better internal support for macros; not yet ready for release.
+	 Added STRING as per R^3.99RS.
+	 More testing of Scheme version of bytecode interpreter.
+	 Better scoping of ##; files can't see command processor context.
+	 OR and CASE don't cons closures.
+	 VM checks for non-existent heap image file, gives error
+	   message instead of "bus error".
+	 Numerous internal changes in compiler and exception system.
+	 Fixed char<?.
+	 Fixed -.5 bug in string->number.
+
+8/26/90  Tested (link-system) inside of T; seems to work.
+	 Benchmark mode available via :BENCH command.
+	 System is 15K bigger due to new fatter global environment
+	   representations.
+	 Inspector abbreviation improved.
+	 Disassembler now works on continuations, sort of.
+
+7/26/90  ((lambda ...) ...) no longer makes a closure
+	 Features now in default system:
+	    :inspect
+	    :dis[assemble]
+	    Generic arithmetic: bignums, rationals, complexes
+	    rationalize
+	    :time command is more verbose
+	 MOREFILES variable in Makefile for loading extra stuff
+	 Default heap size increased to 2 megabytes per semispace
diff --git a/doc/no-leaf-env.txt b/doc/no-leaf-env.txt
new file mode 100644
index 0000000..87a6967
--- /dev/null
+++ b/doc/no-leaf-env.txt
@@ -0,0 +1,175 @@
+Return-Path: <kelsey@ccs.neu.edu>
+Date: Mon, 14 Jun 93 14:34:40 -0400
+To: jar@cs.cornell.edu
+Subject: environments for leaf procedures
+From: kelsey@flora.ccs.neu.edu
+Sender: kelsey@ccs.neu.edu
+
+
+I merged the no-leaf-environments code back into the system, and this
+time it may be worth it.  Loading pp.scm sped up by 2%, even though
+the compiler is doing more work.  Benchmark times (in seconds):
+
+                    old    new   speedup
+quicksort           1.48   1.39     6%
+towers              1.05   1.05     0%
+matrix-multiply     3.32   3.10     7%
+matrix-multiply2    1.94   1.80     7%
+
+Local variable names are screwed up:
+
+  > (define (f x) (let ((y 4)) (+ x y)))
+  > (f 'a)
+
+  Error: exception
+         (+ 'a 4)
+  1> ,debug
+  '#{Continuation (pc 13) f}
+
+   [0] 4
+   [1: y] 'a
+  inspect: 
+
+There is probably a simple fix for this.
+
+Here is the diff:
+
+% diff comp.scm comp.scm.save
+26d25
+< (define $compiling-leaf (make-fluid 'no))
+28,33d26
+< (define (note-not-leaf!)
+<   (set-fluid! $compiling-leaf 'no))
+< 
+< (define (compiling-leaf?)
+<   (eq? 'yes (fluid $compiling-leaf)))
+< 
+63,82c56,66
+<     (deliver-value (if (env-ref? den)
+< 		       (local-variable den cenv depth #f)
+< 		       (instruction-with-variable op/global exp den #f))
+< 		   cont)))
+< 
+< (define (local-variable den cenv depth set?)
+<   (let ((back (env-ref-back den cenv))
+< 	(over (env-ref-over den)))
+<     (if (and (compiling-leaf?)
+< 	     (= back 0))
+< 	(instruction (if set? op/stack-set! op/stack-ref)
+< 		     (+ (- over 1) depth))
+< 	(let ((back (if (compiling-leaf?) (- back 1) back)))
+< 	  (if set?
+< 	      (instruction op/set-local! back over)
+< 	      (case back
+< 		((0) (instruction op/local0 over)) ;+++
+< 		((1) (instruction op/local1 over)) ;+++
+< 		((2) (instruction op/local2 over)) ;+++
+< 		(else (instruction op/local back over))))))))
+---
+>     (if (env-ref? den)
+> 	(let ((back (env-ref-back den cenv))
+> 	      (over (env-ref-over den)))
+> 	  (deliver-value (case back
+> 			   ((0) (instruction op/local0 over)) ;+++
+> 			   ((1) (instruction op/local1 over)) ;+++
+> 			   ((2) (instruction op/local2 over)) ;+++
+> 			   (else (instruction op/local back over)))
+> 			 cont))
+> 	(deliver-value (instruction-with-variable op/global exp den #f)
+> 		       cont))))
+143,145c127,132
+< 	  (if (env-ref? den)
+< 	      (local-variable den cenv depth #t)
+< 	      (instruction-with-variable op/set-global! name den #t)))
+---
+> 	  (cond ((env-ref? den)
+> 		 (instruction op/set-local!
+> 			      (env-ref-back den cenv)
+> 			      (env-ref-over den)))
+> 		(else
+> 		 (instruction-with-variable op/set-global! name den #t))))
+203d189
+<   (note-not-leaf!)  ; this isn't strictly necessary, but it keeps things simpler
+222,231c208,215
+<   (cond ((return-cont? cont) 
+< 	 code)
+< 	(else
+< 	 (note-not-leaf!)  ; this isn't strictly necessary, but it keeps things simpler
+< 	 (sequentially (instruction-with-offset&byte op/make-cont
+< 						     (segment-size code)
+< 						     depth)
+< 		       (note-source-code (cont-source-info cont)
+< 					 code)
+< 		       (cont-segment cont)))))
+---
+>   (if (return-cont? cont) 
+>       code
+>       (sequentially (instruction-with-offset&byte op/make-cont
+> 						  (segment-size code)
+> 						  depth)
+> 		    (note-source-code (cont-source-info cont)
+> 				      code)
+> 		    (cont-segment cont))))
+264d247
+<   (note-not-leaf!)
+280,315c263,284
+<   (let-fluids $compiling-leaf 'maybe
+<     (lambda ()
+<       (let ((code (really-compile-lambda-code formals body cenv name)))
+< 	(if (eq? (fluid $compiling-leaf) 'maybe)
+< 	    (let-fluids $compiling-leaf 'yes
+< 	      (lambda ()
+< 		(really-compile-lambda-code formals body cenv name)))
+< 	    code)))))
+< 
+< (define (really-compile-lambda-code formals body cenv name)
+<   (let* ((nargs (number-of-required-args formals))
+< 	 (vars (normalize-formals formals))
+< 	 (cenv (if (null? formals)
+< 		   cenv			;+++
+< 		   (bind-vars vars cenv))))
+<     (sequentially
+<      (cond ((n-ary? formals)
+< 	    (sequentially
+< 	     (instruction op/make-rest-list nargs)
+< 	     (instruction op/push)
+< 	     (if (compiling-leaf?)
+< 		 empty-segment
+< 		 (instruction op/make-env (+ nargs 1)))))
+< 	   ((null? formals)
+< 	    (note-not-leaf!) ; no point if no variables
+< 	    empty-segment)
+< 	   ((compiling-leaf?)
+< 	    empty-segment)
+< 	   (else
+< 	    (instruction op/make-env nargs)))
+<      (note-environment
+<        vars
+<        (compile-body body
+< 		     cenv
+< 		     0
+< 		     (return-cont name))))))
+---
+>   (if (null? formals)
+>       (compile-body body		;+++ Don't make null environment
+> 		    cenv
+> 		    0
+> 		    (return-cont name))
+>       (sequentially
+>        (let ((nargs (number-of-required-args formals)))
+> 	 (if (n-ary? formals)
+> 	     (sequentially
+> 	      (instruction op/make-rest-list nargs)
+> 	      (instruction op/push)
+> 	      (instruction op/make-env (+ nargs 1)))
+> 	     (instruction op/make-env nargs)))
+>        (let* ((vars (normalize-formals formals))
+> 	      (cenv (bind-vars vars cenv)))
+> 	 (note-environment
+> 	  vars
+> 	  (compile-body body
+> 			cenv
+> 			0
+> 			(return-cont name)))))))
+> 
+
diff --git a/doc/package.txt b/doc/package.txt
new file mode 100644
index 0000000..0532411
--- /dev/null
+++ b/doc/package.txt
@@ -0,0 +1,81 @@
+-- this file is probably obsolete --
+
+The package system interface.  Much too complicated.
+
+Signatures 
+
+	  make-simple-signature
+	  make-compound-signature
+	  signature?
+	  signature-ref
+	  signature-walk
+
+Structures 
+
+	  make-structure
+	  structure?
+	  structure-signature
+	  structure-package
+	  structure-name
+
+Packages
+
+	  make-package
+	  make-simple-package		;start.scm
+
+Lookup and definition operations
+
+	  package-lookup
+	  package-lookup-type           ;comp.scm
+	  package-find-location		;rts/env.scm
+	  package-lookup-location	;segment.scm
+	  probe-package
+	  package-check-assigned
+	  package-check-variable
+
+	  package-define!
+	  package-define-type!     ;hmm.
+	  package-ensure-defined!
+
+Things needed by the form/file/package scanner
+
+	  for-each-definition           ;for integrate-all-primitives!
+	  package-accesses              ;for scan-package
+	  package-clauses		;for scan-package
+	  package-file-name		;for scan-package
+	  package-opens			;for scan-package
+	  package-evaluator             ;for define-syntax
+	  package-for-syntax            ;for define-syntax
+
+Miscellaneous
+
+          $note-undefined               ;eval.scm
+	  noting-undefined-variables	;eval.scm, etc.
+	  package-uid			;eval.scm
+	  set-shadow-action!		;eval.scm
+	  verify-later!			;for the define-structures macro
+	  reset-packages-state!         ;Makefile - for linker
+          initialize-reified-package!   ;for reification
+	  transform-for-structure-ref   ;for reification ?
+
+Inessential (for package mutation, programming environment)
+
+	  check-structure
+	  package-integrate?            ;env/debug.scm
+	  set-package-integrate?!	;env/debug.scm
+	  package-loaded?		;env/load-package.scm
+	  set-package-loaded?!		;env/load-package.scm
+	  package-name			;env/command.scm
+	  package-name-table		;env/debuginfo.scm
+	  package-open!			;env/debug.scm
+	  package-system-sentinel	;env/command.scm
+	  package-unstable?		;env/pacman.scm
+	  package?			;env/command.scm
+	  undefined-variables		;env/debug.scm
+
+Location names (also inessential)
+
+	  flush-location-names
+	  location-name
+	  location-name-table
+	  location-package-name
diff --git a/doc/scheme48.man b/doc/scheme48.man
new file mode 100644
index 0000000..6463bae
--- /dev/null
+++ b/doc/scheme48.man
@@ -0,0 +1,81 @@
+.TH LS48 1
+.\" File scheme48.man:  Manual page template for Scheme 48.
+.\" Replace LS48 with the name of your default image and LLIB with the
+.\" directory containing scheme48vm and default image.
+.SH NAME
+LS48 \- a Scheme interpreter
+.SH SYNOPSIS
+.B LS48
+[-i image] [-h heapsize] [-a argument]
+.SH DESCRIPTION
+.B LS48
+is an implementation of the Scheme programming language as described in
+the
+.I "Revised^4 Report on the Algorithmic Language Scheme."
+A runnable system requires two parts, an executable program that implements
+the Scheme 48 virtual machine, and an image that is used to initialize
+the store of the virtual machine.
+.B LS48
+is a shell script that starts the virtual machine with an image that runs
+in a Scheme command loop.
+.PP
+The
+.B LS48
+command loop reads Scheme expressions, 
+evaluates them, and prints their results.
+It also executes commands, which are identified by an initial comma character.
+Type the command
+.I ,help
+to receive a list of available commands.
+.PP
+The
+.B \-h
+option causes 
+.IR heapsize
+words to be allocated for both semispaces of the copying garbage
+collector.  One word is four bytes.  Cons cells are currently 3 words,
+so if you want to make sure you can allocate, say, a million cons
+cells, you should specify
+.B \-h
+6000000 (actually a little more, to account for the initial heap
+image and breathing room).
+.PP
+The 
+.I ,dump
+and
+.I ,build
+commands put heap images in files.
+The 
+.B \-i
+option causes the initial heap image to be taken from file
+.IR image .
+The
+.B \-a
+option causes a list of strings to be passed as the argument
+to an image generated using the 
+.I ,build
+command.  The first argument to
+.I ,build
+is a procedure that is passed
+the arguments following
+.B \-a
+and which should return an integer (which is the
+return value of the Scheme 48 process).
+.PP
+.nf
+     > ,build (lambda (a) (display a) (newline) 0) foo.image
+     > ,exit
+     $ LS48 -i foo.image -a mumble
+     mumble
+     $ 
+.PP
+.fi
+.SH FILES
+.TP 40
+.B LLIB/scheme48vm
+the virtual machine.
+.TP
+.B LLIB/LS48.image
+the default image.
+.SH BUGS
+Procedure calls with more than 63 explicit arguments might not work.
diff --git a/doc/src/code.tex b/doc/src/code.tex
new file mode 100644
index 0000000..aa8de05
--- /dev/null
+++ b/doc/src/code.tex
@@ -0,0 +1,94 @@
+% Latex Macros for Lisp code in text.
+% Based on macros found in C. Rich's library.
+
+\makeatletter
+
+% \vobeyspaces turns all spaces into non-breakable spaces.
+% Note: this is like \@vobeyspaces except without spurious space in defn.
+
+{\catcode`\ =\active\gdef\vobeyspaces{\catcode`\ =\active\let =\@xobeysp}}
+
+% \def\vobeytabs turns all tabs into 8 non-breakable spaces
+
+{\catcode`\^^I=\active\gdef\vobeytabs{\catcode`\^^I=\active\let^^I=\xvobeytabs}}
+
+\def\xvobeytabs{\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp\@xobeysp}
+
+% \vobeylines turns all cr's into non-breakable \par's
+
+{\catcode`\^^M=\active\gdef\vobeylines{\catcode`\^^M=\active\let^^M=\xvobeylines}}
+
+\def\xvobeylines{\par\penalty10000}
+
+% \obeycrsp turns cr's into non-breakable spaces
+
+{\catcode`\^^M=\active\gdef\obeycrsp{\catcode`\^^M=\active\let^^M=\@xobeysp}}
+
+%% \@noligs prevents ?` and !` from being treated as ligatures
+%% added 19 April 86  [copied from Latex sources]
+
+\begingroup
+\catcode``=13
+\gdef\@noligs{\let`=\@lquote}
+\endgroup
+
+% Set up code environment, in which most of the common special characters
+% appearing in code are treated verbatim, namely: _ # & ^ $ ~ @ " %
+%  *** JAR NEEDED $ AND _ IN SOME CODE ***
+
+% Note: \ { } are still enabled so that macros can be called in this
+% environment.  Use \\, \{ and \} to use these characters verbatim
+% in this environment.  
+
+% Note: this environment allows no breaking of lines whatsoever; not
+% at spaces or hypens.  To arrange for a break use the standard \- macro,
+% or the \= macro which breaks, but inserts nothing.  This is useful,
+% for example for allowing hypenated identifiers to be broken, e.g.
+% FOO-\=BAR.
+
+\def\setupcode{\parsep=0pt\parindent=0pt
+  \tt\frenchspacing\catcode``=13\@noligs%
+  \def\\{\char`\\}%
+  \@makeother\#\@makeother\&\@makeother\^%\@makeother\_\@makeother\$%
+  \@makeother\`\@makeother\'%
+  \@makeother\~\@makeother\@\@makeother\"\@makeother\%\vobeytabs\vobeyspaces}
+
+% Code environment as described above.  Note that blank lines are
+% not preserved, and lines are not kept on one page.  Code is
+% indented by the same amount as quotes.
+% Note: to increase left margin, use \leftmargini=1in.
+%  was  {\list{}{\parsep=0pt}\item[]\setupcode\obeylines}%
+% then {\list{\parsep=0pt\listparindent=0pt\leftmargin=0pt}{}\item[]\setupcode%
+
+\newenvironment{bigcode}%
+  {\list{}{\parsep=0pt\leftmargin=0pt\labelwidth=0pt\itemindent=0pt%
+\listparindent=0pt}\item[]\setupcode%
+\obeylines}%
+  {\endlist}
+
+% Code is just like bigcode, but everything inside is kept on one page
+% Note: This actually works by setting a huge penalty for breaking
+% between lines of code.
+%  was  {\list{}{\parsep=0pt}\item[]\setupcode\vobeylines}%
+
+\newenvironment{code}%
+  {\list{}{\parsep=0pt\leftmargin=0pt\labelwidth=0pt\itemindent=0pt%
+\listparindent=0pt}\item[]\setupcode%
+\vobeylines}%
+  {\endlist}
+
+% Reasonable separation between lines of code
+
+\newcommand{\codeskip}{\penalty0\vspace{2ex}}
+
+% \cd is used to build a code environment in the middle of text.
+% Note: only difference from display code is that cr's are taken
+% as unbreakable spaces instead of \par's.
+
+\newcommand{\cd}{\begingroup\setupcode\obeycrsp\startcode}
+
+\newcommand{\startcode}[1]{#1\endgroup}
+
+%\setbox0\hbox{\@xobeysp}\hline{43\wd0}
+
+\makeatother
diff --git a/doc/src/external.tex b/doc/src/external.tex
new file mode 100644
index 0000000..024f8cb
--- /dev/null
+++ b/doc/src/external.tex
@@ -0,0 +1,888 @@
+\documentclass{article}
+\usepackage{hyperlatex}
+
+\include{proto}
+
+% Make each section be a separate HTML file.
+\setcounter{htmldepth}{1}
+
+\W\newcommand{\langle}{<}
+\W\newcommand{\rangle}{>}
+
+\newcommand{\meta}[1]{{\noindent\mbox{\textrm{$\langle$#1$\rangle$}}}}
+\newcommand{\hyper}[1]{\meta{#1}}
+\newcommand{\hyperi}[1]{\hyper{#1$_1$}}
+\newcommand{\hyperii}[1]{\hyper{#1$_2$}}
+\newcommand{\hyperj}[1]{\hyper{#1$_i$}}
+\newcommand{\hypern}[1]{\hyper{#1$_n$}}
+\renewcommand{\var}[1]{\noindent\mbox{\textit{#1}}}
+\newcommand{\vari}[1]{\var{#1$_1$}}
+\newcommand{\varii}[1]{\var{#1$_2$}}
+\newcommand{\variii}[1]{\var{#1$_3$}}
+\newcommand{\variv}[1]{\var{#1$_4$}}
+\newcommand{\varj}[1]{\var{#1$_j$}}
+\newcommand{\varn}[1]{\var{#1$_n$}}
+
+\W\newcommand{\frenchspacing}{}
+\W\newcommand{\textnormal}[1]{#1}
+
+\newcommand{\defining}[1]{{\emph{#1}}}
+
+\newcommand{\exprtype}{syntax}
+
+\W\newcommand{\unskip}{}
+\W\newcommand{\textrm}[1]{#1}
+
+\newcommand{\dotsfoo}{\ldots\texonly{\thinspace}}
+
+\htmltitle{Mixing Scheme 48 and C}
+\htmladdress{\begin{rawhtml}<a href="http://www-pu.informatik.uni-tuebingen.de/users/sperber/">Mike
+  Sperber</a>, <a href="http://www.neci.nj.nec.com/homepages/kelsey/">Richard Kelsey</a>\end{rawhtml}}
+
+\title{Using C code with Scheme 48}
+\author{Mike Sperber\\\texttt{\small sperber@informatik.uni-tuebingen.de}\\
+  Richard Kelsey\\\texttt{\small kelsey@research.nj.nec.com}
+  }
+
+\makeindex
+
+\begin{document}
+
+\maketitle
+
+\begin{abstract}
+This document describes an interface for calling C functions
+ from Scheme, calling Scheme functions from C, and allocating
+ storage in the Scheme heap.
+These facilities are designed to link
+ existing C libraries into Scheme~48 in order to use them from Scheme.
+To this end, Scheme~48 manages stub functions in C that
+ negotiate between the calling conventions of Scheme and C and the
+ memory allocation policies of both worlds.
+No stub generator is available yet, but writing them is a straightforward task.
+
+\end{abstract}
+
+\section{Available Facilities}
+\label{sec:facilities}
+
+The following facilities are available for interfacing between
+ Scheme~48 and C:
+%
+\begin{itemize}
+\item Scheme code can call C functions.
+\item The external interface provides full introspection for all
+  Scheme objects.  External code may inspect, modify, and allocate
+  Scheme objects arbitrarily.
+\item External code may raise exceptions back to Scheme~48 to
+  signal errors.
+\item External code may call back into Scheme.  Scheme~48
+  correctly unrolls the process stack on non-local exits.
+\item External modules may register bindings of names to values with a 
+  central registry accessible from
+  Scheme.  Conversely, Scheme code can register shared
+  bindings for access by C code.
+\end{itemize}
+%
+This document has three parts: the first describes how bindings are
+ moved from Scheme to C and vice versa, the second tells how to call
+ C functions from Scheme, and the third covers the C interface
+ to Scheme objects, including calling Scheme procedures, using the
+ Scheme heap, and so forth.
+
+\subsection{Scheme structures}
+
+The structure \code{external-calls} has 
+ most of the Scheme functions described here.
+The others are in 
+ \code{dynamic-externals}, which has the functions for dynamic loading and
+ name lookup from
+\texonly{Section~\ref{dynamic-externals},}
+\htmlonly{the section on \link{Dynamic Loading}{dynamic-externals},}
+ and \code{shared-bindings}, which has the additional shared-binding functions
+ described in
+\texonly{Section~\ref{more-shared-bindings}.}
+\htmlonly{the section on the \link{complete shared-binding interface}{more-shared-bindings}.}
+
+\subsection{C naming conventions}
+
+The names of all of Scheme~48's visible C bindings begin 
+ with `\code{s48\_}' (for procedures and variables) or 
+ `\code{S48\_}' (for macros).
+Whenever a C name is derived from a Scheme identifier, we
+ replace `\code{-}' with `\code{\_}' and convert letters to lowercase
+ for procedures and uppercase for macros.
+A final `\code{?}'  converted to `\code{\_p}' (`\code{\_P}' in C macro names).
+A final `\code{!}' is dropped.
+Thus the C macro for Scheme's \code{pair?} is \code{S48\_PAIR\_P} and
+ the one for \code{set-car!} is \code{S48\_SET\_CAR}.
+Procedures and macros that do not check the types of their arguments
+ have `\code{unsafe}' in their names.
+
+All of the C functions and macros described have prototypes or definitions
+ in the file \code{c/scheme48.h}.
+The C type for Scheme values is defined there to be \code{s48\_value}.
+
+\section{Shared bindings}
+\label{sec:shared-bindings}
+
+Shared bindings are the means by which named values are shared between Scheme
+ code and C code.
+There are two separate tables of shared bindings, one for values defined in
+ Scheme and accessed from C and the other for values going the other way.
+Shared bindings actually bind names to cells, to allow a name to be looked
+ up before it has been assigned.
+This is necessary because C initialization code may be run before or after
+ the corresponding Scheme code, depending on whether the Scheme code is in
+ the resumed image or is run in the current session.
+
+\subsection{Exporting Scheme values to C}
+
+\begin{protos}
+\proto{define-exported-binding}{ name value}{shared-binding}
+\end{protos}
+
+\begin{protos}
+\cproto{s48\_value s48\_get\_imported\_binding(char *name)}
+\cproto{s48\_value S48\_SHARED\_BINDING\_REF(s48\_value shared\_binding)}
+\end{protos}
+
+\noindent\code{Define-exported-binding} makes \cvar{value} available to C code
+ under as \cvar{name} which must be a \cvar{string}, creating a new shared
+ binding if necessary.
+The C function \code{s48\_get\_imported\_binding} returns the shared binding
+ defined for \code{name}, again creating it if necessary.
+The C macro \code{S48\_SHARED\_BINDING\_REF} dereferences a shared binding,
+ returning its current value.
+
+\subsection{Exporting C values to Scheme}
+
+\begin{protos}
+\cproto{void s48\_define\_exported\_binding(char *name, s48\_value value)}
+\end{protos}
+
+\begin{protos}
+\proto{lookup-imported-binding}{ string}{shared-binding}
+\proto{shared-binding-ref}{ shared-binding}{value}
+\end{protos}
+
+\noindent These are used to define shared bindings from C and to access them
+ from Scheme.
+Again, if a name is looked up before it has been defined, a new binding is
+ created for it.
+
+The common case of exporting a C function to Scheme can be done using
+ the macro \code{S48\_EXPORT\_FUNCTION(\emph{name})}.
+This expands into
+
+\code{s48\_define\_exported\_binding("\cvar{name}", %
+ s48\_enter\_pointer(\cvar{name}))}
+
+\noindent which boxes the function into a Scheme byte vector and then
+ exports it.
+Note that \code{s48\_enter\_pointer} allocates space in the Scheme heap
+ and might trigger a 
+ \link{garbage collection}[; see Section~\ref{gc}]{gc}.
+
+\begin{protos}
+\syntaxprotonoresult{import-definition}{ \cvar{name}}
+\syntaxprotonoresult{import-definition}{ \cvar{name c-name}}
+\end{protos}
+These macros simplify importing definitions from C to Scheme.
+They expand into
+
+\code{(define \cvar{name} (lookup-imported-binding \cvar{c-name}))}
+
+\noindent{}where \cvar{c-name} is as supplied for the second form.
+For the first form \cvar{c-name} is derived from \cvar{name} by
+ replacing `\code{-}' with `\code{\_}' and converting letters to lowercase.
+For example, \code{(import-definition my-foo)} expands into
+
+\code{(define my-foo (lookup-imported-binding "my\_foo"))}
+
+\subsection{Complete shared binding interface}
+\label{more-shared-bindings}
+
+There are a number of other Scheme functions related to shared bindings;
+ these are in the structure \code{shared-bindings}.
+
+\begin{protos}
+\proto{shared-binding?}{ x}{boolean}
+\proto{shared-binding-name}{ shared-binding}{string}
+\proto{shared-binding-is-import?}{ shared-binding}{boolean}
+\protonoresult{shared-binding-set!}{ shared-binding value}
+\protonoresult{define-imported-binding}{ string value}
+\protonoresult{lookup-exported-binding}{ string}
+\protonoresult{undefine-imported-binding}{ string}{}
+\protonoresult{undefine-exported-binding}{ string}{}
+\end{protos}
+
+\noindent\code{Shared-binding?} is the predicate for shared-bindings.
+\code{Shared-binding-name} returns the name of a binding.
+\code{Shared-binding-is-import?} is true if the binding was defined from C.
+\code{Shared-binding-set!} changes the value of a binding.
+\code{Define-imported-binding} and \code{lookup-exported-binding} are
+ Scheme versions of \code{s48\_define\_exported\_binding}
+ and \code{s48\_lookup\_imported\_binding}.
+The two \code{undefine-} procedures remove bindings from the two tables.
+They do nothing if the name is not found in the table.
+
+The following C macros correspond to the Scheme functions above.
+
+\begin{protos}
+\cproto{int\ \ \ \ \ \ \ S48\_SHARED\_BINDING\_P(x)}
+\cproto{int\ \ \ \ \ \ \ S48\_SHARED\_BINDING\_IS\_IMPORT\_P(s48\_value s\_b)}
+\cproto{s48\_value S48\_SHARED\_BINDING\_NAME(s48\_value s\_b)}
+\cproto{void\ \ \ \ \ \ S48\_SHARED\_BINDING\_SET(s48\_value s\_b, s48\_value value)}
+\end{protos}
+
+\section{Calling C Functions from Scheme}
+\label{sec:external-call}
+
+There are three different ways to call C functions from Scheme, depending on
+ how the C function was obtained.
+
+\begin{protos}
+\proto{call-imported-binding}{ binding arg$_0$ \ldots}{value}
+\proto{call-external}{ external arg$_0$ \ldots}{value}
+\proto{call-external-value}{ value name arg$_0$ \ldots}{value}
+\end{protos}
+\noindent
+Each of these applies its first argument, a C function, to the rest of
+ the arguments.
+For \code{call-imported-binding} the function argument must be an
+ imported binding.
+For \code{call-external} the function argument must be an external
+ bound in the current process
+ (see
+\texonly{Section~\ref{dynamic-externals}).}
+\htmlonly{the section on \link{Dynamic Loading}{dynamic-externals}).}
+For \code{call-external-value} \cvar{value} must be a byte vector
+ whose contents is a pointer to a C function and \cvar{name} should be
+ a string naming the function.
+The \cvar{name} argument is used only for printing error messages.
+
+For all of these, the C function is passed the \cvar{arg$_i$} values
+ and the value returned is that returned by C procedure.
+Up to twelve arguments may be passed.
+There is no method supplied for returning multiple values to
+ Scheme from C (or vice versa) (mainly because C does not have multiple return
+ values).
+
+Keyboard interrupts that occur during a call to a C function are ignored
+ until the function returns to Scheme (this is clearly a
+ problem; we are working on a solution).
+
+\begin{protos}
+\syntaxprotonoresult{import-lambda-definition}
+{ \cvar{name} (\cvar{formal} \ldots)}
+\syntaxprotonoresult{import-lambda-definition}
+{ \cvar{name} (\cvar{formal} \ldots)\ \cvar{c-name}}
+\end{protos}
+\noindent{}These macros simplify importing functions from C.
+They define \cvar{name} to be a function with the given formals that
+ applies those formals to the corresponding C binding.
+\cvar{C-name}, if supplied, should be a string.
+These expand into
+
+\begin{example}
+(define temp (lookup-imported-binding \cvar{c-name}))
+(define \cvar{name}
+  (lambda (\cvar{formal} \ldots)
+    (external-apply temp \cvar{formal} \ldots)))
+\end{example}
+
+\noindent{}
+If \cvar{c-name} is not supplied, it is derived from \cvar{name} by converting
+ all letters to lowercase and replacing `\code{-}' with `\code{\_}'.
+
+\section{Adding external modules to the \code{Makefile}}
+\label{sec:external-modules}
+
+Getting access to C bindings from Scheme requires that the C code be
+ compiled an linked in with the Scheme~48 virtual machine and that the
+ relevent shared-bindings be created.
+The Scheme~48 makefile has rules for compiling and linking external code
+ and for specifying initialization functions that should be called on
+ startup.
+There are three Makefile variables that control which external modules are
+ included in the executable for the virutal machine (\code{scheme48vm}).
+\code{EXTERNAL\_OBJECTS} lists the object files to be included in
+ \code{scheme48vm},
+\code{EXTERNAL\_FLAGS} is a list of \code{ld} flags to be used when
+ creating \code{scheme48vm}, and
+ \code{EXTERNAL\_INITIALIZERS} is a list of C procedures to be called
+ on startup.
+The procedures listed in \code{EXTERNAL\_INITIALIZERS} should take no
+ arguments and have a return type of \code{void}.
+After changing the definitions of any of these variables you should
+ do \code{make scheme48vm} to rebuild the virtual machine.
+
+\section{Dynamic Loading}
+\label{dynamic-externals}
+
+External code can be loaded into a running Scheme~48 process
+ and C object-file bindings can be dereferenced at runtime and
+ their values called
+ (although not all versions of Unix support all of this).
+The required Scheme functions are in the structure \code{dynamic-externals}.
+
+\begin{protos}
+\protonoresult{dynamic-load}{ string}{}
+\end{protos}
+\noindent
+\code{Dynamic-load} loads the named file into the current
+ process, raising an exception if the file cannot be found or if dynamic
+ loading is not supported by the operating system.
+The file must have been compiled and linked appropriately.
+For Linux, the following commands compile \code{foo.c} into a
+ file \code{foo.so} that can be loaded dynamically.
+\begin{example}
+\% gcc -c -o foo.o foo.c
+\% ld -shared -o foo.so foo.o
+\end{example}
+
+\begin{protos}
+\proto{get-external}{ string}{external}
+\proto{external?}{ x}{boolean}
+\proto{external-name}{ external}{string}
+\proto{external-value}{ external}{byte-vector}
+\end{protos}
+\noindent
+These functions give access to values bound in the current process, and
+ are used for retrieving values from dynamically-loaded files.
+\code{Get-external} returns an \var{external} object that contains the
+ value of \cvar{name}, raising an exception if there is no such
+ value in the current process.
+\code{External?} is the predicate for externals, and
+\code{external-name} and \code{external-value} return the name and
+ value of an external.
+The value is returned as byte vector of length four (on 32-bit
+ architectures).
+The value is that which was extant when \code{get-external} was
+ called.
+The following two functions can be used to update the values of
+ externals.
+
+\begin{protos}
+\proto{lookup-external}{ external}{boolean}
+\proto{lookup-all-externals}{}{boolean}
+\end{protos}
+\noindent
+\code{Lookup-external} updates the value of \cvar{external} by looking its
+ name in the current process, returning \code{\#t} if it is bound and \code{\#f}
+ if it is not.
+\code{Lookup-all-externals} calls \code{lookup-external} on all extant
+ externals, returning \code{\#f} any are unbound.
+
+\begin{protos}
+\proto{call-external}{ external arg$_0$ \ldots}{value}
+\end{protos}
+\noindent
+An external whose value is a C procedure can be called using
+ \code{call-external}.
+See
+\texonly{Section~\ref{sec:external-call}}
+\htmlonly{the section on \link{calling C functions from Scheme}{sec:external-call}}
+for more information.
+
+In some versions of Unix retrieving a value from the current
+ process may require a non-trivial amount of computation.
+We recommend that a dynamically-loaded file contain a single initialization
+ procedure that creates shared bindings for the values exported by the file.
+
+\section{Compatibility}
+
+Scheme~48's old \code{external-call} function is still available in the structure
+ \code{externals}, which now also includes \code{external-name} and
+ \code{external-value}.
+The old \code{scheme48.h} file has been renamed \code{old-scheme48.h}.
+
+\section{Accessing Scheme data from C}
+\label{sec:scheme-data}
+
+The C header file \code{scheme48.h} provides
+ access to Scheme~48 data structures
+ (for compatibility, the old \code{scheme48.h} file is available
+ as \code{old-scheme48.h}).
+The type \code{s48\_value} is used for Scheme values.
+When the type of a value is known, such as the integer returned
+ by \code{vector-length} or the boolean returned by \code{pair?},
+ the corresponding C procedure returns a C value of the appropriate
+ type, and not a \code{s48\_value}.
+Predicates return \code{1} for true and \code{0} for false.
+
+\subsection{Constants}
+\label{sec:constants}
+
+The following macros denote Scheme constants:
+%
+\begin{description}
+\item[\code{S48\_FALSE}] is \verb|#f|.
+\item[\code{S48\_TRUE}] is \verb|#t|.
+\item[\code{S48\_NULL}] is the empty list.
+\item[\code{S48\_UNSPECIFIC}] is a value used for functions which have no
+  meaningful return value
+ (in Scheme this value returned by the nullary procedure \code{unspecific}
+ in the structure \code{util}).
+\item[\code{S48\_EOF}] is the end-of-file object
+ (in Scheme this value is returned by the nullary procedure \code{eof-object}
+ in the structure \code{i/o-internal}).
+\end{description}
+
+\subsection{Converting values}
+
+The following functions convert values between Scheme and C
+ representations.
+The `extract' ones convert from Scheme to C and the `enter's go the other
+ way.
+
+\begin{protos}
+\cproto{unsigned char s48\_extract\_char(s48\_value)}
+\cproto{char * \ \ \ s48\_extract\_string(s48\_value)}
+\cproto{long \ \ \ \ \ s48\_extract\_integer(s48\_value)}
+\cproto{double \ \ \ s48\_extract\_double(s48\_value)}
+\cproto{s48\_value s48\_enter\_char(unsigned char)}
+\cgcproto{s48\_value s48\_enter\_string(char *)}
+\cgcproto{s48\_value s48\_enter\_integer(long)}
+\cgcproto{s48\_value s48\_enter\_double(double)}
+\end{protos}
+
+\noindent{}The value returned by \code{s48\_extract\_string} points to the actual
+ storage used by the string; it is valid only until the next
+ \link{garbage collection}[; see Section~\ref{gc}]{gc}.
+
+\code{s48\_enter\_integer()} needs to allocate storage when
+ its argument is too large to fit in a Scheme~48 fixnum.
+In cases where the number is known to fit within a fixnum (currently 30 bits
+ including the sign), the following procedures can be used.
+These have the disadvantage of only having a limited range, but
+ the advantage of never causing a garbage collection.
+
+\begin{protos}
+\cproto{long \ \ \ \ \ s48\_extract\_fixnum(s48\_value)}
+\cproto{s48\_value s48\_enter\_fixnum(long)}
+\cproto{long \ \ \ \ \ S48\_MAX\_FIXNUM\_VALUE}
+\cproto{long \ \ \ \ \ S48\_MIN\_FIXNUM\_VALUE}
+\end{protos}
+
+\noindent An error is signalled if \code{s48\_extract\_fixnum}'s argument
+ is not a fixnum or if the argument to \code{s48\_enter\_fixnum} is less than
+ \code{S48\_MIN\_FIXNUM\_VALUE} or greater than \code{S48\_MAX\_FIXNUM\_VALUE}
+ ($-2^{29}$ and $2^{29}-1$ in the current system).
+
+\subsection{C versions of Scheme procedures}
+
+The following macros and procedures are C versions of Scheme procedures.
+The names were derived by replacing `\code{-}' with `\code{\_}',
+ `\code{?}' with `\code{p}', and dropping `\code{!}.
+
+\begin{protos}
+\cproto{int \ \ \ \ \ \ S48\_EQ\_P(s48\_value)}
+\cproto{int \ \ \ \ \ \ S48\_CHAR\_P(s48\_value)}
+\cproto{int \ \ \ \ \ \ S48\_INTEGER\_P(s48\_value)}
+\end{protos}
+\begin{protos}
+\cproto{int \ \ \ \ \ \ S48\_PAIR\_P(s48\_value)}
+\cproto{s48\_value S48\_CAR(s48\_value)}
+\cproto{s48\_value S48\_CDR(s48\_value)}
+\cproto{void \ \ \ \ \ S48\_SET\_CAR(s48\_value, s48\_value)}
+\cproto{void \ \ \ \ \ S48\_SET\_CDR(s48\_value, s48\_value)}
+\cgcproto{s48\_value s48\_cons(s48\_value, s48\_value)}
+\cproto{long \ \ \ \ \ s48\_length(s48\_value)} 
+\end{protos}
+\begin{protos}
+\cproto{int \ \ \ \ \ \ S48\_VECTOR\_P(s48\_value)} 
+\cproto{long \ \ \ \ \ S48\_VECTOR\_LENGTH(s48\_value)} 
+\cproto{s48\_value S48\_VECTOR\_REF(s48\_value, long)} 
+\cproto{void \ \ \ \ \ S48\_VECTOR\_SET(s48\_value, long, s48\_value)} 
+\cgcproto{s48\_value s48\_make\_vector(long, s48\_value)}
+\end{protos}
+\begin{protos}
+\cproto{int \ \ \ \ \ \ S48\_STRING\_P(s48\_value)} 
+\cproto{long \ \ \ \ \ S48\_STRING\_LENGTH(s48\_value)} 
+\cproto{char \ \ \ \ \ S48\_STRING\_REF(s48\_value, long)} 
+\cproto{void \ \ \ \ \ S48\_STRING\_SET(s48\_value, long, char)} 
+\cgcproto{s48\_value s48\_make\_string(long, char)}
+\end{protos}
+\begin{protos}
+\cproto{int \ \ \ \ \ \ S48\_SYMBOL\_P(s48\_value)} 
+\cproto{s48\_value s48\_SYMBOL\_TO\_STRING(s48\_value)} 
+\end{protos}
+\begin{protos}
+\cproto{int \ \ \ \ \ \ S48\_BYTE\_VECTOR\_P(s48\_value)} 
+\cproto{long \ \ \ \ \ S48\_BYTE\_VECTOR\_LENGTH(s48\_value)} 
+\cproto{char \ \ \ \ \ S48\_BYTE\_VECTOR\_REF(s48\_value, long)} 
+\cproto{void \ \ \ \ \ S48\_BYTE\_VECTOR\_SET(s48\_value, long, int)} 
+\cgcproto{s48\_value s48\_make\_byte\_vector(long, int)}
+\end{protos}
+
+\section{Calling Scheme functions from C}
+\label{sec:external-callback}
+
+External code that has been called from Scheme can call back to Scheme
+ procedures using the following function.
+
+\begin{protos}
+\cproto{scheme\_value s48\_call\_scheme(s48\_value proc, long nargs, \ldots)}
+\end{protos}
+\noindent{}This calls the Scheme procedure \code{proc} on \code{nargs}
+ arguments, which are passed as additional arguments to \code{s48\_call\_scheme}.
+There may be at most ten arguments.
+The value returned by the Scheme procedure is returned by the C procedure.
+Invoking any Scheme procedure may potentially cause a garbage collection.
+
+There are some complications that occur when mixing calls from C to Scheme
+ with continuations and threads.
+C only supports downward continuations (via \code{longjmp()}).
+Scheme continuations that capture a portion of the C stack have to follow the
+ same restriction.
+For example, suppose Scheme procedure \code{s0} captures continuation \code{a}
+ and then calls C procedure \code{c0}, which in turn calls Scheme procedure
+ \code{s1}.
+Procedure \code{s1} can safely call the continuation \code{a}, because that
+ is a downward use.
+When \code{a} is called Scheme~48 will remove the portion of the C stack used
+ by the call to \code{c0}.
+On the other hand, if \code{s1} captures a continuation, that continuation
+ cannot be used from \code{s0}, because by the time control returns to
+ \code{s0} the C stack used by \code{c0} will no longer be valid.
+An attempt to invoke an upward continuation that is closed over a portion
+ of the C stack will raise an exception.
+
+In Scheme~48 threads are implemented using continuations, so the downward
+ restriction applies to them as well.
+An attempt to return from Scheme to C at a time when the appropriate
+ C frame is not on top of the C stack will cause the current thread to
+ block until the frame is available.
+For example, suppose thread \code{t0} calls a C procedure which calls back
+ to Scheme, at which point control switches to thread \code{t1}, which also
+ calls C and then back to Scheme.
+At this point both \code{t0} and \code{t1} have active calls to C on the
+ C stack, with \code{t1}'s C frame above \code{t0}'s.
+If thread \code{t0} attempts to return from Scheme to C it will block,
+ as its frame is not accessable.
+Once \code{t1} has returned to C and from there to Scheme, \code{t0} will
+ be able to resume.
+The return to Scheme is required because context switches can only occur while
+ C code is running.
+\code{T0} will also be able to resume if \code{t1} uses a continuation to
+ throw past its call to C.
+
+\section{Interacting with the Scheme Heap}
+\label{sec:heap-allocation}
+\label{gc}
+
+Scheme~48 uses a copying, precise garbage collector.
+Any procedure that allocates objects within the Scheme~48 heap may trigger
+ a garbage collection.
+Variables bound to values in the Scheme~48 heap need to be registered with
+ the garbage collector so that the value will be retained and so that the
+ variables will be updated if the garbage collector moves the object.
+The garbage collector has no facility for updating pointers to the interiors
+ of objects, so such pointers, for example the ones returned by
+ \code{EXTRACT\_STRING}, will likely become invalid when a garbage collection
+ occurs.
+
+\subsection{Registering Objects with the GC}
+\label{sec:gc-register}
+
+A set of macros are used to manage the registration of local variables with the
+ garbage collector.
+
+\begin{protos}
+\cproto{S48\_DECLARE\_GC\_PROTECT($n$)}
+\cproto{void S48\_GC\_PROTECT\_$n$(s48\_value$_1$, $\ldots$, s48\_value$_n$)}
+\cproto{void S48\_GC\_UNPROTECT()}
+\end{protos}
+
+\code{S48\_DECLARE\_GC\_PROTECT($n$)}, where  $1\leq n\leq 9$, allocates
+ storage for registering $n$ variables.
+At most one use of \code{S48\_DECLARE\_GC\_PROTECT} may occur in a block.
+\code{S48\_GC\_PROTECT\_$n$($v_1$, $\ldots$, $v_n$)} registers the
+ $n$ variables (l-values) with the garbage collector.
+It must be within scope of a \code{S48\_DECLARE\_GC\_PROTECT($n$)}
+ and be before any code which can cause a GC.
+\code{S48\_GC\_UNPROTECT} removes the block's protected variables from
+ the garbage collectors list.
+It must be called at the end of the block after 
+  any code which may cause a garbage collection.
+Omitting any of the three may cause serious and
+ hard-to-debug problems.
+Notably, the garbage collector may relocate an object and
+ invalidate \code{s48\_value} variables which are not protected.
+
+A \code{gc-protection-mismatch} exception is raised if, when a C
+ procedure returns to Scheme, the calls
+ to \code{S48\_GC\_PROTECT()} have not been matched by an equal number of
+ calls to \code{S48\_GC\_UNPROTECT()}.
+
+Global variables may also be registered with the garbage collector.
+
+\begin{protos}
+\cproto{void S48\_GC\_PROTECT\_GLOBAL(\cvar{value})}
+\end{protos}
+
+\noindent{}\code{S48\_GC\_PROTECT\_GLOBAL} permanently registers the
+  variable \cvar{value} (an l-value) with the garbage collector.
+There is no way to unregister the variable.
+
+\subsection{Keeping C data structures in the Scheme heap}
+\label{sec:external-data}
+
+C data structures can be kept in the Scheme heap by embedding them
+ inside byte vectors.
+The following macros can be used to create and access embedded C objects.
+
+\begin{protos}
+\cgcproto{s48\_value S48\_MAKE\_VALUE(type)}
+\cproto{type \ \ \ \ \ S48\_EXTRACT\_VALUE(s48\_value, type)}
+\cproto{type * \ \ \ S48\_EXTRACT\_VALUE\_POINTER(s48\_value, type)}
+\cproto{void \ \ \ \ \ S48\_SET\_VALUE(s48\_value, type, value)}
+\end{protos}
+
+\noindent{}
+\code{S48\_MAKE\_VALUE} makes a byte vector large enough to hold an object
+ whose type is \cvar{type}.
+\code{S48\_EXTRACT\_VALUE} returns the contents of a byte vector cast to
+ \cvar{type}, and \code{S48\_EXTRACT\_VALUE\_POINTER} returns a pointer
+ to the contents of the byte vector.
+The value returned by \code{S48\_EXTRACT\_VALUE\_POINTER} is valid only until
+ the next \link{garbage collection}[(see Section~\ref{gc})]{gc}.
+
+\code{S48\_SET\_VALUE} stores \code{value} into the byte vector.
+
+%There are some convenient macros for external objects that hold
+% arrays:
+%
+%\begin{itemize}
+%\item \code{S48\_MAKE\_ARRAY($b$, $s$)} returns an external object
+%  which holds an array with base type $b$ and size $s$.
+%\item \code{S48\_EXTRACT\_ARRAY(\cvar{value}, $b$)} returns the address of the
+%  array with base type $b$ inside external object \cvar{value}.  It does not
+%  check if \cvar{value} is actually an external object.  Note that the address
+%  returned by \code{S48\_EXTRACT\_ARRAY} is only valid until the next
+%  \link{heap allocation}[ (see
+%  Sec.~\ref{sec:heap-allocation})]{sec:heap-allocation}.
+%\end{itemize}
+
+\subsection{C code and heap images}
+\label{sec:hibernation}
+
+Scheme~48 uses dumped heap images to restore a previous system state.
+The Scheme~48 heap is written into a file in a machine-independent and
+ operating-system-independent format.
+The procedures described above may be used to create objects in the
+ Scheme heap that contain information specific to the current
+ machine, operating system, or process.
+A heap image containing such objects may not work correctly on
+ when resumed.
+
+To address this problem, a record type may be given a `resumer'
+ procedure.
+On startup, the resumer procedure for a type is applied to each record of
+ that type in the image being restarted.
+This procedure can update the record in a manner appropriate to
+ the machine, operating system, or process used to resume the
+ image.
+
+\begin{protos}
+\protonoresult{define-record-resumer}{ record-type procedure}
+\end{protos}
+
+\noindent{}\code{Define-record-resumer} defines \cvar{procedure},
+ which should accept one argument, to be the resumer for
+ \var{record-type}.
+The order in which resumer procedures are called is not specified.
+
+The \cvar{procedure} argument to \code{define-record-resumer} may
+ be \code{\#f}, in which case records of the given type are
+ not written out in heap images.
+When writing a heap image any reference to such a record is replaced by
+ the value of the record's first field, and an exception is raised
+ after the image is written.
+
+\section{Using Scheme records in C code}
+
+External modules can create records and access their slots
+ positionally.
+
+\begin{protos}
+\cgcproto{s48\_value S48\_MAKE\_RECORD(s48\_value)}
+\cproto{int \ \ \ \ \ \ S48\_RECORD\_P(s48\_value)} 
+\cproto{s48\_value S48\_RECORD\_TYPE(s48\_value)} 
+\cproto{s48\_value S48\_RECORD\_REF(s48\_value, long)} 
+\cproto{void \ \ \ \ \ S48\_RECORD\_SET(s48\_value, long, s48\_value)} 
+\end{protos}
+%
+The argument to \code{S48\_MAKE\_RECORD} should be a shared binding
+ whose value is a record type.
+In C the fields of Scheme records are only accessible via offsets,
+ with the first field having offset zero, the second offset one, and
+ so forth.
+If the order of the fields is changed in the Scheme definition of the
+ record type the C code must be updated as well.
+
+For example, given the following record-type definition
+\begin{example}
+(define-record-type thing :thing
+  (make-thing a b)
+  thing?
+  (a thing-a)
+  (b thing-b))
+\end{example}
+ the identifier \code{:thing} is bound to the record type and can
+ be exported to C:
+\begin{example}
+(define-exported-binding "thing-record-type" :thing)
+\end{example}
+\code{Thing} records can then be made in C:
+\begin{example}
+static scheme_value thing_record_type_binding = SCHFALSE;
+
+void initialize_things(void)
+\{
+  S48_GC_PROTECT_GLOBAL(thing_record_type_binding);
+  thing_record_type_binding =
+     s48_get_imported_binding("thing-record-type");
+\}
+
+scheme_value make_thing(scheme_value a, scheme_value b)
+\{
+  s48_value thing;
+  s48_DECLARE_GC_PROTECT(2);
+
+  S48_GC_PROTECT_2(a, b);
+
+  thing = s48_make_record(thing_record_type_binding);
+  S48_RECORD_SET(thing, 0, a);
+  S48_RECORD_SET(thing, 1, b);
+
+  S48_GC_UNPROTECT();
+
+  return thing;
+\}
+\end{example}
+Note that the variables \code{a} and \code{b} must be protected
+ against the possibility of a garbage collection occuring during
+ the call to \code{s48\_make\_record()}.
+
+\section{Raising exceptions from external code}
+\label{sec:exceptions}
+
+The following macros explicitly raise certain errors, immediately
+ returning to Scheme~48.
+Raising an exception performs all
+ necessary clean-up actions to properly return to Scheme~48, including
+ adjusting the stack of protected variables.
+
+\begin{protos}
+\cproto{s48\_raise\_scheme\_exception(int type, int nargs, \ldots)}
+\end{protos}
+
+\noindent{}\code{s48\_raise\_scheme\_exception} is the base procedure for
+ raising exceptions.
+\code{type} is the type of exception, and should be one of the
+ \code{S48\_EXCEPTION\_}\ldots constants defined in \code{scheme48arch.h}.
+\code{nargs} is the number of additional values to be included in the
+ exception; these follow the \code{nargs} argument and should all have
+ type \code{s48\_value}.
+\code{s48\_raise\_scheme\_exception} never returns.
+ 
+The following procedures are available for raising particular
+ types of exceptions.
+Like \code{s48\_raise\_scheme\_exception} these never return.
+
+\begin{protos}
+\cproto{s48\_raise\_argument\_type\_error(scheme\_value)}
+\cproto{s48\_raise\_argument\_number\_error(int nargs, int min, int max)}
+\cproto{s48\_raise\_index\_range\_error(long value, long min, long max)}
+\cproto{s48\_raise\_closed\_channel\_error()}
+\cproto{s48\_raise\_os\_error(int errno)}
+\cproto{s48\_raise\_out\_of\_memory\_error()}
+\end{protos}
+
+\noindent{}An argument type error indicates that the given value is of the wrong
+ type.
+An argument number error is raised when the number of arguments, \code{nargs},
+ should be, but isn't, between \code{min} and \code{max}, inclusive.
+Similarly, and index range error is raised when \code{value} is not between
+ between \code{min} and \code{max}, inclusive.
+
+The following macros raise argument type errors if their argument does not
+ have the required type.
+
+\begin{protos}
+\cproto{void S48\_CHECK\_SYMBOL(s48\_value)}
+\cproto{void S48\_CHECK\_PAIR(s48\_value)}
+\cproto{void S48\_CHECK\_STRING(s48\_value)}
+\cproto{void S48\_CHECK\_INTEGER(s48\_value)}
+\cproto{void S48\_CHECK\_CHANNEL(s48\_value)}
+\cproto{void S48\_CHECK\_BYTE\_VECTOR(s48\_value)}
+\cproto{void S48\_CHECK\_RECORD(s48\_value)}
+\cproto{void S48\_CHECK\_SHARED\_BINDING(s48\_value)}
+\end{protos}
+
+\section{Unsafe functions and macros}
+
+All of the C procedures and macros described above check that their
+ arguments have the appropriate types and that indexes are in range.
+The following procedures and macros are identical to those described
+ above, except that they do not perform type and range checks.
+They are provided for the purpose of writing more efficient code;
+ their general use is not recommended.
+
+\begin{protos}
+\cproto{char \ \ \ \ \ S48\_UNSAFE\_EXTRACT\_CHAR(s48\_value)}
+\cproto{char * \ \ \ S48\_UNSAFE\_EXTRACT\_STRING(s48\_value)}
+\cproto{long \ \ \ \ \ S48\_UNSAFE\_EXTRACT\_INTEGER(s48\_value)}
+\cproto{long \ \ \ \ \ S48\_UNSAFE\_EXTRACT\_DOUBLE(s48\_value)}
+\end{protos}
+\begin{protos}
+\cproto{long \ \ \ \ \ S48\_UNSAFE\_EXTRACT\_FIXNUM(s48\_value)}
+\cproto{s48\_value S48\_UNSAFE\_ENTER\_FIXNUM(long)}
+\end{protos}
+\begin{protos}
+\cproto{s48\_value S48\_UNSAFE\_CAR(s48\_value)}
+\cproto{s48\_value S48\_UNSAFE\_CDR(s48\_value)}
+\cproto{void \ \ \ \ \ S48\_UNSAFE\_SET\_CAR(s48\_value, s48\_value)}
+\cproto{void \ \ \ \ \ S48\_UNSAFE\_SET\_CDR(s48\_value, s48\_value)}
+\end{protos}
+\begin{protos}
+\cproto{long \ \ \ \ \ S48\_UNSAFE\_VECTOR\_LENGTH(s48\_value)} 
+\cproto{s48\_value S48\_UNSAFE\_VECTOR\_REF(s48\_value, long)} 
+\cproto{void \ \ \ \ \ S48\_UNSAFE\_VECTOR\_SET(s48\_value, long, s48\_value)} 
+\end{protos}
+\begin{protos}
+\cproto{long \ \ \ \ \ S48\_UNSAFE\_STRING\_LENGTH(s48\_value)} 
+\cproto{char \ \ \ \ \ S48\_UNSAFE\_STRING\_REF(s48\_value, long)} 
+\cproto{void \ \ \ \ \ S48\_UNSAFE\_STRING\_SET(s48\_value, long, char)} 
+\end{protos}
+\begin{protos}
+\cproto{s48\_value S48\_UNSAFE\_SYMBOL\_TO\_STRING(s48\_value)} 
+\end{protos}
+\begin{protos}
+\cproto{long \ \ \ \ \ S48\_UNSAFE\_BYTE\_VECTOR\_LENGTH(s48\_value)} 
+\cproto{char \ \ \ \ \ S48\_UNSAFE\_BYTE\_VECTOR\_REF(s48\_value, long)} 
+\cproto{void \ \ \ \ \ S48\_UNSAFE\_BYTE\_VECTOR\_SET(s48\_value, long, int)} 
+\end{protos}
+\begin{protos}
+\cproto{s48\_value S48\_UNSAFE\_SHARED\_BINDING\_REF(s48\_value s\_b)}
+\cproto{int\ \ \ \ \ \ \ S48\_UNSAFE\_SHARED\_BINDING\_P(x)}
+\cproto{int\ \ \ \ \ \ \ S48\_UNSAFE\_SHARED\_BINDING\_IS\_IMPORT\_P(s48\_value s\_b)}
+\cproto{s48\_value S48\_UNSAFE\_SHARED\_BINDING\_NAME(s48\_value s\_b)}
+\cproto{void\ \ \ \ \ \ S48\_UNSAFE\_SHARED\_BINDING\_SET(s48\_value s\_b, s48\_value value)}
+\end{protos}
+\begin{protos}
+\cproto{s48\_value S48\_UNSAFE\_RECORD\_TYPE(s48\_value)} 
+\cproto{s48\_value S48\_UNSAFE\_RECORD\_REF(s48\_value, long)} 
+\cproto{void \ \ \ \ \ S48\_UNSAFE\_RECORD\_SET(s48\_value, long, s48\_value)} 
+\end{protos}
+\begin{protos}
+\cproto{type \ \ \ \ \ S48\_UNSAFE\_EXTRACT\_VALUE(s48\_value, type)}
+\cproto{type * \ \ \ S48\_UNSAFE\_EXTRACT\_VALUE\_POINTER(s48\_value, type)}
+\cproto{void \ \ \ \ \ S48\_UNSAFE\_SET\_VALUE(s48\_value, type, value)}
+\end{protos}
+
+\end{document}
+
diff --git a/doc/src/hyperlatex.sty b/doc/src/hyperlatex.sty
new file mode 100644
index 0000000..b6ef1b3
--- /dev/null
+++ b/doc/src/hyperlatex.sty
@@ -0,0 +1,253 @@
+%%
+%% LaTeX style to handle hyperlatex files, version 2.3
+%%
+%%   $Modified: Fri May  9 13:40:27 1997 by otfried $
+%%
+%% This code has GNU copyleft, 1994-1998 Otfried Cheong
+%%
+\NeedsTeXFormat{LaTeX2e}
+
+\ProvidesPackage{hyperlatex}
+[1998/09/08 v2.3 LaTeX2e package for Hyperlatex mode]
+
+\typeout{Package: 'hyperlatex' v2.3  Otfried Cheong}
+
+\RequirePackage{verbatim}
+\chardef\other=12
+
+%%
+%% Comments,  
+%%
+{\obeylines\gdef\Hlx@W#1^^M{\endgroup\ignorespaces}}
+\def\W{\begingroup\obeylines\catcode`\{=\other\catcode`\}=\other\Hlx@W}
+
+\newcommand{\htmlonly}[1]{}
+\newcommand{\texorhtml}[2]{#1}
+\newenvironment{iftex}{}{}
+\newenvironment{latexonly}{}{}
+\newcommand{\texonly}[1]{#1}
+\newcommand{\T}{}
+
+%%
+%% Treatment of special characters
+%%
+
+\def\Hlx@nonspecials{}
+\def\NotSpecial{\def\Hlx@nonspecials}
+\def\Hlx@turnon{\let\do=\@makeother\Hlx@nonspecials}
+\AtBeginDocument{\Hlx@turnon}
+
+\let\htmltab=&
+
+%%
+%% \begin{tex} ... \end{tex}    escapes into raw Tex temporarily.
+%% you can write {\tex .....} as well, if already escaped from Html
+%%
+\newenvironment{tex}{\catcode `\$=3 \catcode `\&=4 \catcode `\#=6
+\catcode `\^=7 \catcode `\_=8 \catcode `\%=14}{}
+
+%%
+%% \back
+%% 
+
+\newcommand{\back}{{\tt\char`\\}}
+
+%%
+%% \math
+%%
+
+\def\math{\@ifnextchar [{\@math}{\@math[]}}
+\def\@math[#1]{\begingroup\tex\@@math}
+\def\@@math#1{$#1$\endgroup}
+
+%%
+%% Commands that don't do anything interesting in Latex
+%%
+
+\def\Hlx@pass{\begingroup\let\protect\@unexpandable@noexpand\@sanitize}
+
+\def\Hlx@directory{.}
+
+\newcommand{\htmldirectory}[1]{\gdef\Hlx@directory{#1}}
+\newcommand{\htmlname}[1]{}
+\newcommand{\htmldepth}[1]{}
+\newcommand{\htmltopname}[1]{}
+\newcounter{htmldepth}
+\newcommand{\htmltitle}[1]{}
+\newcommand{\htmladdress}[1]{}
+\newcommand{\html}{\Hlx@pass\@html}
+\def\@html#1{\endgroup}
+
+\newcommand{\htmlsym}[1]{}
+\def\htmlrule{\@ifnextchar [{\@htmlrule}{\@htmlrule[]}}
+\def\@htmlrule{\Hlx@pass\@@htmlrule}
+\def\@@htmlrule[#1]{\endgroup}
+
+\newcommand{\htmllevel}[1]{}
+\newcommand{\htmlmenu}[1]{}
+\newcommand{\htmlautomenu}[1]{}
+\newcounter{htmlautomenu}
+\newcommand{\htmlprintindex}{}
+\newcommand{\htmlfootnotes}{}
+\newcommand{\htmlmathitalic}[1]{}
+
+\def\htmlimage{\@ifnextchar [{\@htmlimage}{\@htmlimage[]}}
+\def\@htmlimage{\Hlx@pass\@@htmlimage}
+\def\@@htmlimage[#1]#2{\endgroup}
+
+\newcommand{\xname}{\Hlx@pass\Hlx@ignore}
+\def\Hlx@ignore#1{\endgroup}
+
+\newcommand{\htmlpanel}[1]{}
+\newcommand{\htmlheading}{\@ifnextchar[{\@htmlheading}{\@htmlheading[]}}
+\def\@htmlheading[#1]#2{}
+
+\newcommand{\htmlcaption}[1]{}
+
+\def\htmlattributes{\@ifstar{\@htmlattributes}{\@htmlattributes}}
+\def\@htmlattributes{\Hlx@pass\@@htmlattributes}
+\def\@@htmlattributes#1#2{\endgroup}
+
+%%
+%% GIF environment,
+%%  will generate bitmaps when `\makegifs' is defined
+%%
+
+\newif\if@makegifs
+\@ifundefined{makegifs}{\@makegifsfalse}{\@makegifstrue}
+
+\def\gif{\@ifnextchar[{\@gif}{\@gif[b]}}
+\def\@gif[#1]{\@ifnextchar[{\@@gif}{\@@gif[100]}}
+\def\@@gif[#1]{\gdef\gif@resolution{#1}\@ifnextchar[{\@@@gif}{\@@@gif[300]}}
+\def\@@@gif[#1]#2{\gdef\gif@dpi{#1}\gdef\gif@name{#2}\@@@@gif}
+
+\if@makegifs
+\typeout{**********************************************}
+\typeout{* Making GIF bitmaps from Hyperlatex source! *}
+\typeout{**********************************************}
+\newwrite\@makegifcmds
+\immediate\openout\@makegifcmds=\jobname.makegif
+\newbox\@gifbox
+\newcount\@gifcount\@gifcount=10000
+\def\@@@@gif{\setbox\@gifbox=\vbox\bgroup\tex}
+\def\endgif{\egroup
+  {\global\advance\@gifcount by 1\count0=\@gifcount
+    \immediate\write\@makegifcmds{dvips\space -f\space -p\space
+      \the\@gifcount\space -n\space 1\space -E\space -D\space \gif@dpi\space
+      \jobname.dvi\space>\space\gif@name.ps^^J%
+      ps2gif\space -res\space \gif@resolution\space \gif@name.ps^^J%
+      mv\space \gif@name.gif\space \Hlx@directory^^J}
+    \shipout\copy\@gifbox}\unvbox\@gifbox}
+\else
+\def\@@@@gif{\tex}
+\def\endgif{}
+\fi
+%%
+%% Font style definitions
+%%
+
+\let\cit=\textit
+\let\code=\texttt
+\let\kbd=\texttt
+\let\samp=\texttt
+\let\strong=\textbf
+\let\var=\textsl
+\let\dfn=\textit
+\let\file=\textit
+
+%%
+%% \begin{example} ... \end{example} obeys spaces and lines
+%%
+%% the indent can be controlled by \exampleindent
+%%
+\newdimen\exampleindent
+\setlength{\exampleindent}{7mm}
+\def\Hlx@example{\do\$\do\&\do\#\do\^\do\_\do\~}
+{\obeyspaces
+  \gdef\turnon@spaces{\let =\ \obeyspaces\catcode``=\active\@noligs}}
+{\obeylines%
+  \gdef\turnon@lines{\obeylines\def^^M{\par\def^^M{\leavevmode\par}}}}
+
+\def\example{\list{}{\leftmargin\exampleindent
+    \itemindent\z@ \rightmargin\z@ \parsep \z@ plus\p@}\item[]\tt
+  \turnon@spaces\turnon@lines\let\do\@makeother\Hlx@example}
+\let\endexample=\endlist
+
+%%
+%% font problem:  math in example environment seems to need this:
+%%
+\DeclareFontFamily{OMS}{cmtt}{}
+\DeclareFontShape{OMS}{cmtt}{m}{n}{ <-> ssub * cmsy/m/n }{}
+
+\newenvironment{menu}{\list{$\bullet$}{\itemsep0pt\parsep0pt}}{\endlist}
+\newenvironment{ifhtml}{\comment}{\endcomment}
+\newenvironment{rawhtml}{\comment}{\endcomment}
+
+\def\htmlinclude#1{}
+
+\def\Hlx@empty{}
+\def\Hlx@zero{0}
+\newif\if@Hlx
+
+\def\Hlx@setclear#1{\@ifundefined{#1}{\@Hlxfalse}{%
+    \expandafter\ifx\csname#1\endcsname\Hlx@empty\@Hlxfalse
+    \else\expandafter\ifx\csname#1\endcsname\Hlx@zero\@Hlxfalse
+    \else\@Hlxtrue\fi\fi}}
+
+\def\ifclear#1{\Hlx@setclear{#1}
+  \if@Hlx
+  %% arg empty -> skip
+  \let\endifset\endcomment\let\Hlx@comment\comment
+  \else
+  %% arg set -> ignore begin and end
+  \let\endifset\relax\let\Hlx@comment\relax
+  \fi\Hlx@comment}
+
+\def\ifset#1{\Hlx@setclear{#1}
+  \if@Hlx
+  % arg empty -> ignore begin and end
+  \let\endifclear\relax\let\Hlx@comment\relax
+  \else
+  % arg set  -> skip environment
+  \let\endifclear\endcomment\let\Hlx@comment\comment
+  \fi\Hlx@comment}
+
+%%
+%% Define \link and \xlink macros
+%%
+\newcommand{\Hlx@label}{}
+
+\newcommand{\Ref}{\ref{\Hlx@label}}
+\newcommand{\Pageref}{\pageref{\Hlx@label}}
+\newcommand{\Cite}{\cite{\Hlx@label}}
+
+\newenvironment{Label}[1]{\def\Hlx@Label@label{\label{#1}}\ignorespaces}%
+{\Hlx@Label@label\ignorespaces}
+
+\newcommand{\htmlcite}[1]{\cite{#1}}
+
+\def\link{\@ifstar{\@star@link}{\@@link}}
+\def\@@link#1{#1\@@@link}
+\def\@star@link#1{\@@@link}
+\def\@@@link{\@ifnextchar [{\@link}% ] balance
+  {\@link[]}}
+\def\@link[#1]#2{\gdef\Hlx@label{#2}#1}
+
+\def\xlink{\@ifstar{\@star@xlink}{\@@xlink}}
+\def\@@xlink#1{\@@@xlink{#1}}
+\def\@star@xlink#1{\@@@xlink{}}
+\def\@@@xlink#1{\@ifnextchar [{\@xlink{#1}}{\@xlink{#1}[]}}
+\def\@xlink#1[#2]#3{\formatxlink{#1#2}{#3}}
+\newcommand{\formatxlink}[2]{#1}
+
+%
+% index from latex.tex, and changed to include optional argument
+%
+\def\cindex{\@bsphack\begingroup
+  \let\protect\@unexpandable@noexpand
+  \@sanitize
+  \@ifnextchar [{\Hlx@argwrindex}% balance ]
+  {\@wrindex}}
+\def\Hlx@argwrindex[#1]#2{\@wrindex{#1@#2}}
+
+%% end of hyperlatex.sty
diff --git a/doc/src/meeting.tex b/doc/src/meeting.tex
new file mode 100644
index 0000000..4a696cb
--- /dev/null
+++ b/doc/src/meeting.tex
@@ -0,0 +1,439 @@
+\documentstyle[11pt,twoside]{article}
+
+\input{code}
+\input{latex-stuff}
+
+\advance \textheight by 2ex
+
+\begin{document}
+
+\begin{center}
+{\Large\bf The Scheme of Things:} \\
+\vspace{2ex}
+{\Large\bf The June 1992 Meeting$^{\hbox{\scriptsize 1}}$} \\
+\vspace{3ex}
+Jonathan Rees \\
+Cornell University \\
+{\tt jar@cs.cornell.edu}
+\end{center}
+
+\vspace{3ex}
+
+\footnotetext[1]{To appear in {\em Lisp Pointers} V(4),
+October--December 1992.}
+
+
+An informally constituted group of people interested in the future of
+the Scheme programming language met at the Xerox Palo Alto Research
+Center on 25 June 1992.  The main purpose of the meeting was to work
+on the technical content of the next revision of the Scheme report.
+
+We made progress on several fronts:
+\begin{itemize}
+\item Some differences with the IEEE Scheme standard were resolved.
+
+\item Proposals for multiple return values and {\tt dynamic-wind} were
+adopted.
+
+\item A proposal for an {\tt eval} procedure was adopted.
+
+\item The high-level macro facility described in the 
+Revised$^4$ Report's appendix will be moved into the report proper.
+\end{itemize}
+
+Two subcommittees were formed: one to work on exceptions, and one to
+charter the formation of a standard library.  The subcommittees will
+report back to the group with proposals for inclusion in the report.
+
+It had been hoped that there would be progress on some other fronts
+(user-defined types, dynamic binding, improvements to ``rest''
+parameters), but after inconclusive discussion these topics were
+dropped.  These topics will probably be taken up again in the future.
+
+Norman Adams was appointed the Revised$^5$ Report's editor.  It is
+hoped that it will be ready by early 1993, so as to precede the
+reconstitution of the IEEE standard group.
+
+This article is my own interpretation of what transpired, and should
+not be construed as definitive.
+
+
+\piece{Agreement with the IEEE Scheme standard}
+
+Until now, the Scheme reports have encouraged but not required the
+empty list {\tt()} and the boolean false value {\tt\#f} to be
+distinct.  It has been the intent ever since the Revised Revised
+Report, however, that this distinction would eventually be required.
+The IEEE Scheme standard bit the bullet in 1990, and now the
+Revised$^5$ report follows.
+
+The standard also dropped the distinction between essential and
+not-essential language features; most features that were formerly not
+essential, such as n-ary {\tt+} and {\tt apply}, are now required.
+The Revised$^5$ Report will adopt this stance, at least as regards
+language features that are shared with the IEEE standard.
+Non-essential non-IEEE oddities such as {\tt transcript-on} and {\tt
+transcript-off} and the proposed {\tt interaction-\ok{}environment} (see
+below) were not discussed at the meeting, however, and consensus on
+their status will have to be reached via electronic mail.
+
+A third aspect of the standard that was adopted was a certain obscure
+paragraph regarding assignments to top-level variables (section 6,
+paragraph 2).  The effect of this is that if a program contains an
+assignment to any top-level variable, then the program must contain a
+{\tt define} for that variable; it is not sufficient that the variable
+be bound.  This has been the case for most variables, but the rule
+applies as well to variables such as {\tt car} that have built-in
+bindings.  In addition, it is clarified that if a program makes such a
+definition or assignment, then the behavior of built-in procedures
+will not be affected.  For example, redefining {\tt length} cannot
+affect the behavior of the built-in {\tt list->vector} procedure.
+If in some particular implementation {\tt list->vector} is written
+in Scheme and calls {\tt length}, then it must be sure to call the
+built-in {\tt length} procedure, not whatever happens to be the value
+of the variable {\tt length}.
+
+
+\piece{Multiple return values}
+
+The {\tt call-with-values} and {\tt values} procedures were described
+in an earlier Scheme of Things ({\em Lisp Pointers}, volume IV, number
+1), but I'll review them here.  The following is adapted from John Ramsdell's
+concise description:
+
+\begin{list}{}{}{}\item
+    {\tt(values \var{object} $\ldots$)}
+        \hfill {\rm essential procedure}
+
+    {\tt values} delivers all of its arguments to its continuation.  
+
+    \vspace{2ex}
+
+    {\tt(call-with-values \var{thunk} \var{receiver})}
+        \hfill {\rm essential procedure}
+
+    {\tt call-with-values} calls its \var{thunk} argument with a
+    continuation that, when passed some values, calls the
+    \var{receiver} procedure with those values as arguments.
+    The continuation for the call to \var{receiver} is the
+    continuation of the call to {\tt call-with-values}.
+\end{list}
+
+Except for continuations created by the {\tt call-with-values}
+procedure, all continuations take exactly one value, as now; the
+effect of passing no value or more than one value to continuations
+that were not created by {\tt call-with-values} is unspecified (as
+indeed it is unspecified now).
+
+{\tt values} might be defined as follows:
+\begin{code}
+    (define (values . things)
+      (call-with-current-continuation 
+        (lambda (cont) (apply cont things))))
+\end{code}
+That is, the procedures supplied by {\tt
+call-with-current-continuation} must be passed the same number of
+arguments as values expected by the continuation.
+
+Because the behavior of a number-of-values mismatch between a
+continuation and its invoker is unspecified, some implementations may
+assign some specific meaning to such situations; for example, extra
+values might be ignored, or defaults might be supplied for missing
+values.  Thus this multiple return value proposal is compatible with
+Common Lisp's multiple values, but strictly more conservative than it.
+The behavior of programs in such situations was a point of contention
+among the authors, which is why only the least common denominator
+behavior was specified.
+
+
+\piece{Unwind/wind protection}
+
+{\tt dynamic-wind}, which was described previously in this column (when it
+was The Scheme Environment; {\em Lisp Pointers}, volume I, number 2),
+is already implemented in many Scheme dialects.  {\tt dynamic-wind}
+takes three arguments, all of which are thunks (procedures of no arguments).
+It behaves as if it were defined with
+\begin{code}
+    (define (dynamic-wind before during after)
+      (before)
+      (call-with-values during
+        (lambda results
+          (after)
+          (apply values results))))
+\end{code}
+except that the execution of the {\tt during} thunk is ``protected''
+against non-local entries and exits: a throw out of the execution
+of {\tt during} will cause the {\tt after} thunk to be invoked, and a
+throw from outside back in will cause the {\tt before} thunk to be
+invoked.  (By ``throw'' I mean an invocation of an explicit
+continuation as obtained from {\tt call-with-current-continuation}.)
+
+For details, the earlier Scheme Environment column refers the reader
+to Friedman and Haynes's paper ``Constraining Control'' in POPL 1985,
+but to save you the trouble of looking that up, I have supplied a more
+direct implementation of {\tt dynamic-wind} in an appendix to the
+present column.
+
+{\tt dynamic-wind} was adopted with the following clarifications: The
+semantics of {\tt(dynamic-wind \var{before} \var{during} \var{after})}
+should leave unspecified what happens if a throw occurs out of {\em
+before} or {\em after}\/; and it is best to defer interrupts during {\em
+before} and {\em after}.
+
+
+
+\piece{Evaluating computed expressions}
+
+The original 1975 memo on Scheme described {\tt evaluate},
+which was analogous to Lisp's traditional {\tt eval} function.  {\tt
+evaluate} took a single argument, an S-expression, and invoked an
+interpreter on it.  For example:
+\begin{code}
+    (let ((name '+)) (evaluate (list name 2 3)))
+        \ev  5
+\end{code}
+Scheme being lexically scoped, however, there was some confusion over
+which environment the expression was to be evaluated in.  Should
+\begin{code}
+    (let ((name '+))
+      (let ((+ *))
+        (evaluate (list name 2 3))))
+\end{code}
+evaluate to 5 or to 6?
+
+To clarify matters, the Revised Report replaced {\tt evaluate} with
+{\tt enclose}, which took two arguments, a {\tt lambda}-expression and
+a representation of an environment from which to supply bindings of the
+{\tt lambda}-expression's free variables.  For example:
+\begin{code}
+    (let ((name '+))
+      (let ((+ *))
+        ((enclose (list 'lambda '() (list name 2 3))
+                  (list (cons '+ +))))))
+        \ev  6
+\end{code}
+This forced the programmer to be explicit about the {\tt
+lambda}-expression's enclosing environment.
+
+For various technical and practical reasons, there was no {\tt eval}
+analogue in subsequent Scheme reports.  The major stumbling blocks
+were how to describe {\tt eval} formally and how to define something
+that makes sense in all extant variants of the language.  Some Scheme
+implementations contain a distinguished top-level environment, while
+others extend the language by providing ways to create multiple
+environments, any of which might serve equally well.
+
+The {\tt eval} proposal adopted at the June meeting, which I reproduce
+here, is one that comes from Bill Rozas.
+
+\begin{list}{}{}{}\item
+
+    {\tt(eval \var{expression} \var{environment-specifier})}
+        \hfill {\rm essential procedure}
+
+    {\tt eval} evaluates \var{expression} in the environment indicated
+    by {\em environment-\discretionary{}{}{}specifier}.  {\em
+    environment-specifier} may be the return value of one of the three
+    procedures described below, or implementation-specific extensions.
+    No other operations on environment specifiers are defined by this
+    proposal.
+
+    Implementations may allow non-expression programs (i.e.\
+    definitions) as the first argument to {\tt eval} \var{only} when
+    the second argument is the return value of {\tt interaction-environment}
+    or some implementation extension.  In other words, {\tt eval} will never
+    create new bindings in the return value of {\tt null-environment} or
+    {\tt scheme-report-environment}.
+
+    \vspace{2ex}
+
+    {\tt(scheme-report-environment \var{version})}
+        \hfill {\rm essential procedure}
+
+    {\em Version} must be an exact non-negative integer corresponding to a
+    version of one of the Revised$^n$ Reports on Scheme.  This procedure
+    returns a specifier for an environment that contains exactly the
+    set of bindings specified in the corresponding report that the
+    implementation supports.  Not all versions may be available in all
+    implementations at all times.  However, an implementation that
+    conforms to version $n$ of the Revised$^n$ Reports on Scheme must
+    accept version $n$.  If {\tt scheme-report-environment} is
+    available, but the specified version is not, the procedure will
+    signal an error.
+
+    The effect of assigning (through the use of {\tt eval}) a variable
+    bound in a {\tt scheme-report-environment} (e.g.\ {\tt car}) is
+    unspecified. Thus the environments specified by the return
+    values of {\tt scheme-report-environment} may be immutable.
+
+    \vspace{2ex}
+
+    {\tt(null-environment)}
+        \hfill {\rm essential procedure}
+
+    This procedure returns a specifier for an environment that contains no
+    variable bindings, but contains (syntactic) bindings for all the
+    syntactic keywords defined in the report, and no others.
+
+    \vspace{2ex}
+    %\newpage  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+    {\tt(interaction-environment)}
+        \hfill {\rm procedure}
+
+    This procedure returns a specifier for an environment that
+    contains imple\-men\-ta\-tion-defined bindings, typically a superset of
+    those listed in the report.  The intent is that this procedure
+    will return a specifier for the environment in which the
+    implementation would evaluate expressions dynamically typed by the
+    user.
+
+\end{list}
+
+Rozas explains:
+``The proposal does not imply the existence or support of first-class
+environments, although it is compatible with them.
+The proposal only requires a way of associating tags with a finite set
+of distinguished environments which the implementations can maintain
+implicitly (without reification).
+
+``\,`Pascal-like' implementations can support both {\tt null-environment} and
+%\penalty0
+{\tt scheme-report-environment} since the environments specified by
+the return values of these procedures need not share any bindings with
+the current program.  A version of {\tt eval} that supports these but
+not {\tt interaction-environment} can be written portably,
+but can be better written by the implementor, since it can share code
+with the default evaluator or compiler.''
+
+Here ``Pascal-like'' refers to implementations that are restricted to
+static compilation and linking.  Because an {\tt eval} that doesn't
+support
+\penalty0
+{\tt interaction-\discretionary{}{}{}environment} can be written
+entirely in the Scheme language described by the rest of the report,
+it raises no troublesome questions about its formal semantics.
+
+
+\piece{Macros}
+
+The consensus of the meeting was that {\tt define-syntax}, {\tt
+syntax-rules}, {\tt let-\discretionary{}{}{}syntax}, and {\tt
+letrec-syntax} should be moved out of the report's appendix into the
+main body of the report.  Although everyone agrees that a low-level
+macro facility is important, the subject is too contentious at
+present, with three or more competing proposals at present.  The
+disposition of the rest of the appendix and of the other low-level
+proposals will be left up to the report's editor.
+
+
+\piece{Committee work}
+
+There is a strong sense that some kind of exception system is needed.
+However, no specific proposal was ready at the time of the meeting.  A
+committee has been formed to work on one.  What seems to be in the
+air might be described as a highly distilled version of the condition
+system that Kent Pitman developed for Common Lisp.  I hope that I'll
+be able to report on this in a future column.
+
+
+On the subject of libraries, Will Clinger's minutes report that
+``the authors perceive a need to give some library official status.  In
+fact, we need to give official sanction to multiple libraries.  There
+is reason to distinguish between accepted (or standard) libraries,
+experimental libraries, and proposals.  The accepted libraries can
+reduce the intellectual size of the language by removing things like
+{\tt string->list} from the report.  The experimental libraries would
+contain solid implementations of experimental features, including
+things that might never deserve to be in the report.  The proposal
+libraries could contain anything implemented in portable Scheme.''
+
+
+Among the content of the accepted libraries, some features (such as
+those that may be moved out of the body of the report) may be required
+to be built in to implementations, while others will be expected to be
+available on demand (perhaps using something similar to, but not the
+same as, {\tt require} as found in Common Lisp and GNU Emacs).
+
+A librarian was appointed (Rees), and a library committee is
+developing proposals for the charter, structure, and content of the
+libraries.
+
+
+\separator
+
+I would like to acknowledge Will Clinger, who prepared the minutes of
+the meeting, and the various people who contributed proposals,
+including Bill Rozas and John Ramsdell.  Any errors here are my
+responsibility, however.  Thanks also to Norman Adams and Richard
+Kelsey for corrections to a draft of this article.
+
+I would also like to belatedly acknowledge Norman Adams, Pavel
+Curtis, Bruce Donald, and Richard Kelsey for their comments on drafts of
+my previous column.
+
+For future columns, I am entertaining various topic possibilities,
+including {\tt eval}, threads, {\tt amb}, and monads.
+If you have other ideas, and particularly if you think the written
+record on the language is particularly poor in certain areas, please
+write and let me know.
+
+\vspace{2ex}
+
+%\newpage
+
+%\bgroup \small
+
+\piece{Appendix: An implementation of {\tt dynamic-wind}}
+
+This program is based on my vague recollection of an ancient
+manuscript by Chris Hanson and John Lamping.  I apologize for the lack
+of data abstraction, but the code is more concise this way.
+
+A state space is a tree with the current state at the root.  Each node other
+than the root is a triple $\langle\var{before}, \var{after},
+\var{parent}\rangle$, represented in this implementation as two pairs
+{\tt((\var{before} .\ \var{after}) .\ \var{parent})}.
+Navigating between states requires re-rooting the tree by reversing
+parent-child links.
+
+Since {\tt dynamic-wind} interacts with {\tt
+call-with-current-continuation}, this implementation must replace the
+usual definition of the latter.
+
+\begin{code}
+(define *here* (list #f))
+\codeskip
+(define original-cwcc call-with-current-continuation)
+\codeskip
+(define (call-with-current-continuation proc)
+  (let ((here *here*))
+    (original-cwcc (lambda (cont)
+                     (proc (lambda results
+                             (reroot! here)
+                             (apply cont results)))))))
+\codeskip
+(define (dynamic-wind before during after)
+  (let ((here *here*))
+    (reroot! (cons (cons before after) here))
+    (call-with-values during
+      (lambda results
+        (reroot! here)
+        (apply values results)))))
+\codeskip
+(define (reroot! there)
+  (if (not (eq? *here* there))
+      (begin (reroot! (cdr there))
+             (let ((before (caar there))
+                   (after (cdar there)))
+               (set-car! *here* (cons after before))
+               (set-cdr! *here* there)
+               (set-car! there #f)
+               (set-cdr! there '())
+               (set! *here* there)
+               (before)))))
+\end{code}
+
+%\egroup
+
+\end{document}
diff --git a/doc/src/module.tex b/doc/src/module.tex
new file mode 100644
index 0000000..212d948
--- /dev/null
+++ b/doc/src/module.tex
@@ -0,0 +1,728 @@
+\documentstyle[11pt]{article}
+
+\include{code}
+\include{latex-stuff}
+
+\newcommand{\goesto}{\hbox{$\longrightarrow$}}
+\newcommand{\alt}{$\vert$}
+\newcommand{\arbno}[1]{{{#1}$^*$}}
+\newcommand{\hack}{Scheme~48}
+
+\begin{document}
+
+\begin{center}
+{\Large\bf Another Module System for Scheme}
+
+\vspace{2ex}
+Jonathan Rees \\
+3 January 1993 (updated 15 January 1994)
+\end{center}
+
+\vspace{3ex}
+
+This memo describes a module system for the Scheme programming
+language.  The module system is unique in the extent to which it
+supports both static linking and rapid turnaround during program
+development.  The design was influenced by Standard ML
+modules\cite{MacQueen:Modules} and by the module system for Scheme
+Xerox\cite{Curtis-Rauen:Modules}.  It has also been shaped by the
+needs of \hack{}, a virtual-machine-based Scheme implementation
+designed to run both on workstations and on relatively small (less
+than 1 Mbyte) embedded controllers.
+
+Except where noted, everything described here is implemented in
+\hack{}, and exercised by the \hack{} implementation and a few
+application programs.
+
+Unlike the Common Lisp package system, the module system described
+here controls the mapping of names to denotations, not the
+mapping of strings to symbols.
+
+
+\subsection*{Introduction}
+
+The module system supports the structured division of a corpus of
+Scheme software into a set of modules.  Each module has its own
+isolated namespace, with visibility of bindings controlled by module
+descriptions written in a special {\em configuration language.}
+
+A module may be instantiated multiple times, producing several {\em
+packages}, just as a lambda-expression can be instantiated multiple
+times to produce several different procedures.  Since single
+instantiation is the normal case, I will defer discussion of multiple
+instantiation until a later section.  For now you can think of a
+package as simply a module's internal environment mapping names to
+denotations.
+
+A module exports bindings by providing views onto the underlying
+package.  Such a view is called a {\em structure} (terminology from
+Standard ML).  One module may provide several different views.  A
+structure is just a subset of the package's bindings.  The particular
+set of names whose bindings are exported is the structure's {\em
+interface}.
+
+A module imports bindings from other modules by either {\em opening}
+or {\em accessing} some structures that are built on other packages.
+When a structure is opened, all of its exported bindings are visible
+in the client package.  On the other hand, bindings from an accessed
+structure require explicitly qualified references written with the
+{\tt structure-ref} operator.
+
+For example:
+\begin{code}
+    (define-structure foo (export a c cons)
+      (open scheme)
+      (begin (define a 1)
+             (define (b x) (+ a x))
+             (define (c y) (* (b a) y))))
+\codeskip
+    (define-structure bar (export d)
+      (open scheme foo)
+      (begin (define (d w) (+ a (c w)))))
+\end{code}
+This configuration defines two structures, {\tt foo} and {\tt bar}.
+{\tt foo} is a view on a package in which the {\tt scheme} structure's
+bindings (including {\tt define} and {\tt +}) are visible, together
+with bindings for {\tt a}, {\tt b},
+and {\tt c}.  {\tt foo}'s interface is {\tt (export a c cons)}, so of
+the bindings in its underlying package, {\tt foo} only exports those
+three.  Similarly, structure {\tt bar} consists of the binding of {\tt
+d} from a package in which both {\tt scheme}'s and {\tt foo}'s
+bindings are visible.  {\tt foo}'s binding of {\tt cons} is imported
+from the Scheme structure and then re-exported.
+
+A module's body, the part following {\tt begin} in the above example,
+is evaluated in an isolated lexical scope completely specified by the
+package definition's {\tt open} and {\tt access} clauses.  In
+particular, the binding of the syntactic operator {\tt define-structure}
+is not visible unless it comes from some opened structure.  Similarly,
+bindings from the {\tt scheme} structure aren't visible unless they
+become so by {\tt scheme} (or an equivalent structure) being opened.
+
+
+\subsection*{The configuration language}
+
+The configuration language consists of top-level defining forms for
+modules and interfaces.  Its syntax is given in figure~1.
+
+\setbox0\hbox{\goesto}
+\newcommand{\altz}{\hbox to 1\wd0{\hfil\alt}}
+
+%%%%% Put the figure inside a box ?
+
+\begin{figure}
+%\begin{frameit}
+\begin{tabbing}
+   \syn{configuration} \=\goesto{}~\arbno{\syn{definition}} \\
+   \syn{definition} \=\goesto{}~
+      \tt(define-structure \syn{name} \syn{interface}
+          \arbno{\syn{clause}}) \\
+        \>\altz{}~ \tt(define-structures (\arbno{(\syn{name} \syn{interface})})
+          \arbno{\syn{clause}}) \\
+        \>\altz{}~ \tt(define-interface \syn{name} \syn{interface}) \\
+        \>\altz{}~ \tt(define-syntax \syn{name} \syn{transformer-spec}) \\
+   \syn{clause} \=\goesto{}~ \tt(open \arbno{\syn{name}}) \\
+        \>\altz{}~ \tt(access \arbno{\syn{name}}) \\
+        \>\altz{}~ \tt(begin \syn{program}) \\
+        \>\altz{}~ \tt(files \arbno{\syn{filespec}}) \\
+        \>\altz{}~ \tt(optimize \arbno{\syn{optimize-spec}}) \\
+        \>\altz{}~ \tt(for-syntax \arbno{\syn{clause}}) \\
+   \syn{interface} \=\goesto{}~ \tt(export \arbno{\syn{item}}) \\
+        \>\altz{}~ \syn{name} \\
+        \>\altz{}~ \tt(compound-interface \arbno{\syn{interface}}) \\
+   \syn{item} \=\goesto{}~ \syn{name}~ 
+          \alt{}~ \tt(\syn{name} \syn{type})
+          \alt{}~ \tt((\arbno{\syn{name}}) \syn{type})
+\end{tabbing}
+\caption{The configuration language.}
+%\end{frameit}
+\end{figure}
+
+
+A {\tt define-structure} form introduces a binding of a name to a
+structure.  A structure is a view on an underlying package which is
+created according to the clauses of the {\tt define-structure} form.
+Each structure has an interface that specifies which bindings in the
+structure's underlying package can be seen via that structure in other
+packages.
+
+An {\tt open} clause specifies which structures will be opened up for
+use inside the new package.  At least one package must be specified or
+else it will be impossible to write any useful programs inside the
+package, since {\tt define}, {\tt lambda}, {\tt cons}, {\tt
+structure-ref}, etc.\ will be unavailable.  Typical packages to list
+in the {\tt open} clause are {\tt scheme}, which exports all bindings
+appropriate to Revised$^5$ Scheme, and {\tt structure-refs}, which
+exports the {\tt structure-ref} operator (see below).  For building
+structures that export structures, there is a {\tt defpackage} package
+that exports the operators of the configuration language.  Many other
+structures, such as record and hash table facilities, are also
+available in the \hack{} implementation.
+
+An {\tt access} clause specifies which bindings of names to structures
+will be visible inside the package body for use in {\tt structure-ref}
+forms.  {\tt structure-\ok{}ref} has the following syntax:
+\begin{tabbing}
+\qquad \syn{expression} \goesto{}~
+   \tt(structure-ref \syn{struct-name} \syn{name})
+\end{tabbing}
+The \syn{struct-name} must be the name of an {\tt access}ed structure,
+and \syn{name} must be something that the structure exports.  Only
+structures listed in an {\tt access} clause are valid in a {\tt
+structure-ref}.  If a package accesses any structures, it should
+probably open the {\tt structure-refs} structure so that the {\tt
+structure-ref} operator itself will be available.
+
+The package's body is specified by {\tt begin} and/or {\tt files}
+clauses.  {\tt begin} and {\tt files} have the same semantics, except
+that for {\tt begin} the text is given directly in the package
+definition, while for {\tt files} the text is stored somewhere in the
+file system.  The body consists of a Scheme program, that is, a
+sequence of definitions and expressions to be evaluated in order.  In
+practice, I always use {\tt files} in preference to {\tt begin}; {\tt
+begin} exists mainly for expository purposes.
+
+A name's imported binding may be lexically overridden or {\em shadowed}
+by simply defining the name using a defining form such as {\tt define}
+or {\tt define-\ok{}syntax}.  This will create a new binding without having
+any effect on the binding in the opened package.  For example, one can
+do {\tt(define car 'chevy)} without affecting the binding of the name
+{\tt car} in the {\tt scheme} package.
+
+Assignments (using {\tt set!})\ to imported and undefined variables
+are not allowed.  In order to {\tt set!}\ a top-level variable, the
+package body must contain a {\tt define} form defining that variable.
+Applied to bindings from the {\tt scheme} structure, this restriction
+is compatible with the requirements of the Revised$^5$ Scheme report.
+
+It is an error for two of a package's opened structures to export two
+different bindings for the same name.  However, the current
+implementation does not check for this situation; a name's binding is
+always taken from the structure that is listed first within the {\tt
+open} clause.  This may be fixed in the future.
+
+File names in a {\tt files} clause can be symbols, strings, or lists
+(Maclisp-style ``namelists'').  A ``{\tt.scm}'' file type suffix is
+assumed.  Symbols are converted to file names by converting to upper
+or lower case as appropriate for the host operating system.  A
+namelist is an operating-system-indepedent way to specify a file
+obtained from a subdirectory.  For example, the namelist {\tt(rts
+record)} specifies the file {\tt record.scm} in the {\tt rts}
+subdirectory.
+
+If the {\tt define-structure} form was itself obtained from a file,
+then file names in {\tt files} clauses are interpreted relative to the
+directory in which the file containing the {\tt define-structure} form
+was found.  You can't at present put an absolute path name in the {\tt
+files} list.
+
+
+\subsection*{Interfaces}
+
+An interface can be thought of as the type of a structure.  In its
+basic form it is just a list of variable names, written {\tt(export
+\var{name} \etc)}.  However, in place of
+a name one may write {\tt(\var{name} \var{type})}, indicating the type
+of \var{name}'s binding.  Currently the type field is ignored, except
+that exported macros must be indicated with type {\tt :syntax}.
+
+Interfaces may be either anonymous, as in the example in the
+introduction, or they may be given names by a {\tt define-interface}
+form, for example
+\begin{code}
+    (define-interface foo-interface (export a c cons))
+    (define-structure foo foo-interface \etc)
+\end{code}
+In principle, interfaces needn't ever be named.  If an interface
+had to be given at the point of a structure's use as well as at the
+point of its definition, it would be important to name interfaces in
+order to avoid having to write them out twice, with risk of mismatch
+should the interface ever change.  But they don't.
+
+Still, there are several reasons to use {\tt define-interface}:
+\begin{enumerate}
+\item It is important to separate the interface definition from the
+package definitions when there are multiple distinct structures that
+have the same interface --- that is, multiple implementations of the
+same abstraction.
+
+\item It is conceptually cleaner, and useful for documentation
+purposes, to separate a module's specification (interface) from its
+implementation (package).
+
+\item My experience is that configurations that are separated into
+interface definitions and package definitions are easier to read; the
+long lists of exported bindings just get in the way most of the time.
+\end{enumerate}
+
+The {\tt compound-interface} operator forms an interface that is the
+union of two or more component interfaces.  For example,
+\begin{code}
+    (define-interface bar-interface
+      (compound-interface foo-interface (export mumble)))
+\end{code}
+defines {\tt bar-interface} to be {\tt foo-interface} with the name
+{\tt mumble} added.
+
+
+\subsection*{Macros}
+
+Hygienic macros, as described in
+\cite{Clinger-Rees:Macros,Clinger-Rees:R4RS}, are implemented.
+Structures may export macros; auxiliary names introduced into the
+expansion are resolved in the environment of the macro's definition.
+
+For example, the {\tt scheme} structure's {\tt delay} macro 
+is defined by the rewrite rule
+\begin{code}
+    (delay \var{exp})  \xform  (make-promise (lambda () \var{exp}))\rm.
+\end{code}
+The variable {\tt make-promise} is defined in the {\tt scheme}
+structure's underlying package, but is not exported.  A use of the
+{\tt delay} macro, however, always accesses the correct definition
+of {\tt make-promise}.  Similarly, the {\tt case} macro expands into
+uses of {\tt cond}, {\tt eqv?}, and so on.  These names are exported
+by {\tt scheme}, but their correct bindings will be found even if they
+are shadowed by definitions in the client package.
+
+
+\subsection*{Higher-order modules}
+
+There are {\tt define-module} and {\tt define} forms for
+defining modules that are intended to be instantiated multiple times.
+But these are pretty kludgey --- for example, compiled code isn't
+shared between the instantiations --- so I won't describe them yet.
+If you must know, figure it out from the following grammar.
+\begin{tabbing}
+\qquad
+   \syn{definition} \=\goesto{}~
+      \tt(d\=\tt{}efine-module (\syn{name} \arbno{(\syn{name} \syn{interface})}) \\
+       \>  \>\arbno{\syn{definition}} \\
+       \>  \>\syn{name}\tt) \\
+        \>\altz{}~ \tt(define \syn{name}
+                        (\syn{name} \arbno{\syn{name}}))
+\end{tabbing}
+
+
+\subsection*{Compiling and linking}
+
+\hack{} has a static linker that produces stand-alone heap images
+from module descriptions.  One specifies a particular procedure in a
+particular structure to be the image's startup procedure (entry
+point), and the linker traces dependency links as given by {\tt open}
+and {\tt access} clauses to determine the composition of the heap
+image.
+
+There is not currently any provision for separate compilation; the
+only input to the static linker is source code.  However, it will not
+be difficult to implement separate compilation.  The unit of
+compilation is one module (not one file).  Any opened or accessed
+structures from which macros are obtained must be processed to the
+extent of extracting its macro definitions.  The compiler knows from
+the interface of an opened or accessed structure which of its exports
+are macros.  Except for macros, a module may be compiled without any
+knowledge of the implementation of its opened and accessed structures.
+However, inter-module optimization will be available as an option.
+
+The main difficulty with separate compilation is resolution of
+auxiliary bindings introduced into macro expansions.  The module
+compiler must transmit to the loader or linker the search path by
+which such bindings are to be resolved.  In the case of the {\tt delay}
+macro's auxiliary {\tt make-promise} (see example above), the loader
+or linker needs to know that the desired binding of {\tt make-promise}
+is the one apparent in {\tt delay}'s defining package, not in the
+package being loaded or linked.
+
+[I need to describe structure reification.]
+
+
+\subsection*{Semantics of configuration mutation}
+
+During program development it is often desirable to make changes to
+packages and interfaces.  In static languages it may be necessary to
+recompile and re-link a program in order for such changes to be
+reflected in a running system.  Even in interactive Common Lisp
+implementations, a change to a package's exports often requires
+reloading clients that have already mentioned names whose bindings
+change.  Once {\tt read} resolves a use of a name to a symbol, that
+resolution is fixed, so a change in the way that a name resolves to a
+symbol can only be reflected by re-{\tt read}ing all such references.
+
+The \hack{} development environment supports rapid turnaround in
+modular program development by allowing mutations to a program's
+configuration, and giving a clear semantics to such mutations.  The
+rule is that variable bindings in a running program are always
+resolved according to current structure and interface bindings, even
+when these bindings change as a result of edits to the configuration.
+For example, consider the following:
+\begin{code}
+    (define-interface foo-interface (export a c))
+    (define-structure foo foo-interface
+      (open scheme)
+      (begin (define a 1)
+             (define (b x) (+ a x))
+             (define (c y) (* (b a) y))))
+    (define-structure bar (export d)
+      (open scheme foo)
+      (begin (define (d w) (+ (b w) a))))
+\end{code}
+This program has a bug.  The variable {\tt b}, which is free in the
+definition of {\tt d}, has no binding in {\tt bar}'s package.  Suppose
+that {\tt b} was supposed to be exported by {\tt foo}, but was omitted
+from {\tt foo-interface} by mistake.  It is not necessary to
+re-process {\tt bar} or any of {\tt foo}'s other clients at this point.
+One need only change {\tt foo-interface} and inform the development
+system of that one change (using, say, an appropriate Emacs command),
+and {\tt foo}'s binding of {\tt b} will be found when procedure {\tt
+d} is called.
+
+Similarly, it is also possible to replace a structure; clients of the
+old structure will be modified so that they see bindings from the new
+one.  Shadowing is also supported in the same way.  Suppose that a
+client package $C$ opens a structure {\tt foo} that exports a name
+{\tt x}, and {\tt foo}'s implementation obtains the binding of {\tt x}
+as an import from some other structure {\tt bar}.  Then $C$ will see
+the binding from {\tt bar}.  If one then alters {\tt foo} so that it
+shadows {\tt bar}'s binding of {\tt x} with a definition of its own,
+then procedures in $C$ that reference {\tt x} will automatically see
+{\tt foo}'s definition instead of the one from {\tt bar} that they saw
+earlier.
+
+This semantics might appear to require a large amount of computation
+on every variable reference: The specified behavior requires scanning
+the package's list of opened structures, examining their interfaces,
+on every variable reference, not just at compile time.  However, the
+development environment uses caching with cache invalidation to make
+variable references fast.
+
+
+\subsection*{Command processor support}
+
+While it is possible to use the \hack{} static linker for program
+development, it is far more convenient to use the development
+environment, which supports rapid turnaround for program changes.  The
+programmer interacts with the development environment through a {\em
+command processor}.  The command processor is like the usual Lisp
+read-eval-print loop in that it accepts Scheme forms to evaluate.
+However, all meta-level operations, such as exiting the Scheme system
+or requests for trace output, are handled by {\em commands,} which are
+lexically distinguished from Scheme forms.  This arrangement is
+borrowed from the Symbolics Lisp Machine system, and is reminiscent of
+non-Lisp debuggers.  Commands are a little easier to type than Scheme
+forms (no parentheses, so you don't have to shift), but more
+importantly, making them distinct from Scheme forms ensures that
+programs' namespaces aren't clutterred with inappropriate bindings.
+Equivalently, the command set is available for use regardless of what
+bindings happen to be visible in the current program.  This is
+especially important in conjunction with the module system, which puts
+strict controls on visibility of bindings.
+
+The \hack{} command processor supports the module system with a
+variety of special commands.  For commands that require structure
+names, these names are resolved in a designated configuration package
+that is distinct from the current package for evaluating Scheme forms
+given to the command processor.  The command processor interprets
+Scheme forms in a particular current package, and there are commands
+that move the command processor between different packages.
+
+Commands are introduced by a comma ({\tt,}) and end at the end of
+line.  The command processor's prompt consists of the name of the
+current package followed by a greater-than ({\tt>}).
+
+\begin{list}{}{}{}
+
+\item
+\begin{code}
+,config
+\end{code}
+    The {\tt,config} command sets the command processor's current
+    package to be the current configuration package.  Forms entered at
+    this point are interpreted as being configuration language forms,
+    not Scheme forms.
+
+\item
+\begin{code}
+,config \var{command}
+\end{code}
+    This form of the {\tt,config} command executes another command in
+    the current configuration package.  For example,
+\begin{code}
+    ,config ,load foo.scm
+\end{code}
+    interprets configuration language forms from the file {\tt
+    foo.scm} in the current configuration package.
+
+\item
+\begin{code}
+,in \var{struct-name}
+\end{code}
+    The {\tt ,in} command moves the command processor to a specified
+    structure's underlying package.  For example:
+\begin{code}
+    user> ,config
+    config> (define-structure foo (export a)
+              (open scheme))
+    config> ,in foo
+    foo> (define a 13)
+    foo> a
+    13
+\end{code}
+    In this example the command processor starts in a package called
+    {\tt user}, but the {\tt ,config} command moves it into the
+    configuration package, which has the name {\tt config}.  The {\tt
+    define-structure} form binds, in {\tt config}, the name {\tt foo} to
+    a structure that exports {\tt a}.  Finally, the command {\tt ,in
+    foo} moves the command processor into structure {\tt foo}'s
+    underlying package.
+
+    A package's body isn't executed (evaluated) until the package is
+    {\em loaded}, which is accomplished by the {\tt ,load-package}
+    command.
+
+\item
+\begin{code}
+,in \var{struct-name} \var{command}
+\end{code}
+    This form of the {\tt,in} command executes a single command in the
+    specified package without moving the command processor into that
+    package.  Example:
+\begin{code}
+    ,in mumble (cons 1 2)
+    ,in mumble ,trace foo
+\end{code}
+
+\item
+\begin{code}
+,user $[$\var{command}$]$
+\end{code}
+    This is similar to the {\tt ,config} and {\tt ,in} commands.  It
+    moves to or executes a command in the user package (which is the
+    default package when the \hack{} command processor starts).
+
+\item
+\begin{code}
+,for-syntax $[$\var{command}$]$
+\end{code}
+    This is similar to the {\tt ,config} and {\tt ,in} commands.  It
+    moves to or executes a command in the current package's ``package
+    for syntax,'' which is the package in which the forms $f$ in
+    {\tt (define-syntax \var{name} $f$)} are evaluated.
+
+\item
+\begin{code}
+,load-package \var{struct-name}
+\end{code}
+    The {\tt,load-package} command ensures that the specified structure's
+    underlying package's program has been loaded.  This 
+    consists of (1) recursively ensuring that the packages of any
+    opened or accessed structures are loaded, followed by (2)
+    executing the package's body as specified by its definition's {\tt
+    begin} and {\tt files} forms.
+
+\item
+\begin{code}
+,reload-package \var{struct-name}
+\end{code}
+    This command re-executes the structure's package's program.  It
+    is most useful if the program comes from a file or files, when
+    it will update the package's bindings after mutations to its
+    source file.
+
+\item
+\begin{code}
+,load \var{filespec} \etc
+\end{code}
+    The {\tt,load} command executes forms from the specified file or
+    files in the current package.  {\tt,load \var{filespec}} is similar
+    to {\tt(load "\var{filespec}")}
+    except that the name {\tt load} needn't be bound in the current
+    package to Scheme's {\tt load} procedure.
+
+\item
+\begin{code}
+,structure \var{name} \var{interface}
+\end{code}
+    The {\tt,structure} command defines \var{name} in the
+    configuration package to be a structure with interface
+    \var{interface} based on the current package.
+
+\item
+\begin{code}
+,open \arbno{\var{struct-name}}
+\end{code}
+    The {\tt,open} command opens a new structure in the current
+    package, as if the package's definition's {\tt open} clause
+    had listed \var{struct-name}.
+
+\end{list}
+
+
+
+\subsection*{Configuration packages}
+
+It is possible to set up multiple configuration packages.  The default
+configuration package opens the following structures:
+\begin{itemize}
+\item {\tt module-system}, which exports {\tt define-structure} and the
+      other configuration language keywords, as well as standard types
+      and type constructors ({\tt :syntax}, {\tt :value}, {\tt proc}, etc.).
+\item {\tt built-in-structures}, which exports structures that are
+      built into the initial \hack{} image; these include {\tt
+      scheme}, {\tt tables}, and {\tt records}.
+\item {\tt more-structures}, which exports additional structures that
+      are available in the development environment; these include
+      {\tt sort}, {\tt random}, and {\tt threads}.
+\end{itemize}
+Note that it does not open {\tt scheme}.
+
+You can define other configuration packages by simply making a package
+that opens {\tt module-system} and, optionally, {\tt
+built-in-\ok{}structures}, {\tt more-\ok{}structures}, or other structures that
+export structures and interfaces.
+
+For example:
+\begin{code}
+    > ,config (define-structure foo (export )
+                (open module-system
+                      built-in-structures
+                      more-structures))
+    > ,in foo
+    foo> (define-structure x (export a b)
+           (open scheme)
+           (files x))
+    foo> 
+\end{code}
+
+\begin{list}{}{}{}
+\item
+\begin{code}
+,config-package-is \var{struct-name}
+\end{code}
+    The {\tt,config-package-is} command designates a new configuration
+    package for use by the {\tt,config} command and resolution of
+    \var{struct-name}s for other commands such as {\tt,in} and
+    {\tt,open}.
+\end{list}
+
+
+
+\subsection*{Discussion}
+
+This module system was not designed as the be-all and end-all of
+Scheme module systems; it was only intended to help Richard Kelsey and
+me to organize the \hack{} system.  Not only does the module system
+help avoid name clashes by keeping different subsystems in different
+namespaces, it has also helped us to tighten up and generalize
+\hack{}'s internal interfaces.  \hack{} is unusual among Lisp
+implementations in admitting many different possible modes of
+operation.  Examples of such multiple modes include the following:
+\begin{itemize}
+    \item Linking can be either static or dynamic.
+
+    \item The development environment (compiler, debugger, and command
+    processor) can run either in the same address space as the program
+    being developed or in a different address space.  The environment and
+    user program may even run on different processors under different
+    operating systems\cite{Rees-Donald:Program}.
+
+    \item The virtual machine can be supported by either
+    of two implementations of its implementation language, Prescheme.
+\end{itemize}
+The module system has been helpful in organizing these multiple modes.
+By forcing us to write down interfaces and module dependencies, the
+module system helps us to keep the system clean, or at least to keep
+us honest about how clean or not it is.
+
+The need to make structures and interfaces second-class instead of
+first-class results from the requirements of static program analysis:
+it must be possible for the compiler and linker to expand macros and
+resolve variable bindings before the program is executed.  Structures
+could be made first-class (as in FX\cite{Sheldon-Gifford:Static}) if a
+type system were added to Scheme and the definitions of exported
+macros were defined in interfaces instead of in module bodies, but
+even in that case types and interfaces would remain second-class.
+
+The prohibition on assignment to imported bindings makes substitution
+a valid optimization when a module is compiled as a block.  The block
+compiler first scans the entire module body, noting which variables
+are assigned.  Those that aren't assigned (only {\tt define}d) may be
+assumed never assigned, even if they are exported.  The optimizer can
+then perform a very simple-minded analysis to determine automatically
+that some procedures can and should have their calls compiled in line.
+
+The programming style encouraged by the module system is consistent
+with the unextended Scheme language.  Because module system features
+do not generally show up within module bodies, an individual module
+may be understood by someone who is not familiar with the module
+system.  This is a great aid to code presentation and portability.  If
+a few simple conditions are met (no name conflicts between packages,
+no use of {\tt structure-ref}, and use of {\tt files} in preference to
+{\tt begin}), then a multi-module program can be loaded into a Scheme
+implementation that does not support the module system.  The \hack{}
+static linker satisfies these conditions, and can therefore run in
+other Scheme implementations.  \hack{}'s bootstrap process, which is
+based on the static linker, is therefore nonincestuous.  This
+contrasts with most other integrated programming environments, such as
+Smalltalk-80, where the system can only be built using an existing
+version of the system itself.
+
+Like ML modules, but unlike Scheme Xerox modules, this module system
+is compositional.  That is, structures are constructed by single
+syntactic units that compose existing structures with a body of code.
+In Scheme Xerox, the set of modules that can contribute to an
+interface is open-ended --- any module can contribute bindings to any
+interface whose name is in scope.  The module system implementation is
+a cross-bar that channels definitions from modules to interfaces.  The
+module system described here has simpler semantics and makes
+dependencies easier to trace.  It also allows for higher-order
+modules, which Scheme Xerox considers unimportant.
+
+%[Discuss use of module system in the \hack{} implementation?  Maybe
+%give an extended excerpt from \hack{}'s configuration files?]
+%
+%[Discuss or flush OPTIMIZE clause.]
+%
+%[Future work: ideas for anonymous structures and more of a module
+%calculus; dealing with name conflicts; interface subtraction.]
+
+
+\begin{thebibliography}{10}
+
+\bibitem{Clinger-Rees:Macros}
+William Clinger and Jonathan~Rees.
+\newblock Macros that work.
+\newblock {\em Principles of Programming Languages}, January 1991.
+
+\bibitem{Clinger-Rees:R4RS}
+William Clinger and Jonathan~Rees (editors).
+\newblock Revised${}^4$ report on the algorithmic language {S}cheme.
+\newblock {\em LISP Pointers} IV(3):1--55, July-September 1991.
+
+\bibitem{Curtis-Rauen:Modules}
+Pavel Curtis and James Rauen.
+\newblock A module system for Scheme.
+\newblock {\em ACM Conference on Lisp and Functional Programming,}
+pages 13--19, 1990.
+
+\bibitem{MacQueen:Modules}
+David MacQueen.
+\newblock Modules for Standard ML.
+\newblock {\em ACM Conference on Lisp and Functional Programming,}
+1984.
+
+\bibitem{Rees-Donald:Program}
+Jonathan Rees and Bruce Donald.
+\newblock Program mobile robots in Scheme.
+\newblock {\em International Conference on Robotics and
+Automation,} IEEE, 1992. 
+
+\bibitem{Sheldon-Gifford:Static}
+Mark A.~Sheldon and David K.~Gifford.
+\newblock Static dependent types for first-class modules.
+\newblock {\em ACM Conference on Lisp and Functional Programming,}
+pages 20--29, 1990.
+
+\end{thebibliography}
+
+
+\end{document}
diff --git a/doc/src/proto.tex b/doc/src/proto.tex
new file mode 100644
index 0000000..9123f3e
--- /dev/null
+++ b/doc/src/proto.tex
@@ -0,0 +1,97 @@
+\newcommand{\xsubsection}[1]{%
+\texonly{\subsection{#1}}%
+\htmlonly{\strong{#1}\\}%
+}
+
+\newcommand{\evalsto}{%
+\texonly{$\rightarrow$}%
+\htmlonly{\code{->}}%
+}
+
+\newcommand{\cvar}[1]{%
+\texonly{{\rm\em{#1}}}%
+\htmlonly{\code{\var{#1}}}%
+}
+
+%%%%%%%%%%%%%%%% Latex prototypes
+\texonly{
+\newenvironment{protos}{\list{$\bullet$}
+{\leftmargin1.2em\rightmargin0pt\itemsep0pt\parsep0pt\partopsep-2pt}}
+{\endlist}
+
+% The following is for prototypes that have return types.
+%    (foo int int) -> int
+
+\newcommand{\proto}[3]{\item\noindent\unskip%
+\cindex{\code{#1}}%
+\hbox{\spaceskip=0.5em\code{({#1}{\it#2\/})} {$\rightarrow$} {\it#3}}}
+
+\newcommand{\cproto}[1]{\item\noindent\unskip%
+\hbox{\spaceskip=0.5em\code{{#1}}}}
+
+\newcommand{\cgcproto}[1]{\item\noindent\unskip%
+\hbox{\spaceskip=0.5em\code{{#1}}}\hfill\penalty 0%
+\hbox{ }\nobreak\hfill\hbox{\rm (may GC)}}
+
+\newcommand{\protonoresult}[2]{\item\noindent\unskip%
+\hbox{\spaceskip=0.5em\code{(\hbox{#1}{\it#2\/})}}}
+
+% Syntax prototypes
+
+\newcommand{\syntaxprotonoresult}[2]{\item\noindent\unskip%
+\hbox{\spaceskip=0.5em\code{(\hbox{#1}{#2})}}\hfill\penalty 0%
+\hbox{ }\nobreak\hfill\hbox{\rm syntax}}
+
+\newcommand{\syntaxproto}[3]{\syntaxprotonoresult{#1}{#2}%
+\hspace*{24pt}{$\rightarrow$} {\it#3}}
+
+% This can be reduced
+
+\newcommand{\pconstproto}[2]{\item\noindent\unskip%
+\hbox{\spaceskip=0.5em#1}\code\hfill\penalty 0%
+\hbox{ }\nobreak\hfill\hbox{\rm #2}}
+
+% Variable prototype
+\newcommand{\constproto}[2]{\pconstproto{#1}{#2}}
+
+}
+%%%%%%%%%%%%%%%% end of Latex proto definitions
+
+%%%%%%%%%%%%%%%% HTML prototypes
+\htmlonly{
+\newenvironment{protos}{\begin{itemize}}{\end{itemize}}
+
+% The following is for prototypes that have return types.
+%    (foo int int) -> int
+
+\newcommand{\proto}[3]{%
+%\cindex{\code{#1}}%
+\item\noindent\code{({#1}{\var{#2}\/})~-->~{\var{#3}}}}
+
+\newcommand{\protonoresult}[2]{%
+%\cindex{\code{#1}}%
+\item\noindent\code{({#1}{\var{#2}\/})}}
+
+\newcommand{\constproto}[2]{%
+\item\noindent\prototagstart\code{{#1}}\prototag{{#2}}}
+
+\newcommand{\cproto}[1]{%
+\item\noindent\code{{#1}}}
+
+\newcommand{\cgcproto}[1]{%
+\item\noindent\prototagstart\code{{#1}}\prototag{(may GC)}}
+
+\newcommand{\syntaxprotonoresult}[2]{%
+\item\noindent\prototagstart\code{({#1}{#2})}\prototag{syntax}}
+
+\newcommand{\prototagstart}{%
+\begin{rawhtml}<table border=0 cellspacing=0 cellpadding=0 width=80%>
+<tr> <td>\end{rawhtml}}
+
+\newcommand{\prototag}[1]{%
+\begin{rawhtml}</td> <td align=right>\end{rawhtml}%
+{#1}%
+\begin{rawhtml}</td></tr></table>\end{rawhtml}}
+
+}
+%%%%%%%%%%%%%%%% end of HTML proto definitions
diff --git a/doc/src/summary.tex b/doc/src/summary.tex
new file mode 100644
index 0000000..17c8555
--- /dev/null
+++ b/doc/src/summary.tex
@@ -0,0 +1,83 @@
+\documentstyle[11pt]{article}
+
+\pagestyle{empty}
+\setlength{\textheight}{9in}
+\setlength{\footheight}{0.0in}
+\setlength{\topmargin}{0in}
+
+%Defaults from art10.sty:
+%\textwidth 345pt \columnsep 10pt \columnseprule 0pt 
+%\oddsidemargin 63pt
+
+\advance\textwidth by 0.5in
+\advance\oddsidemargin by -0.25in
+
+
+\begin{document}
+
+\vspace*{-0.3in}
+
+\begin{center}
+{\large\bf Scheme 48} \\
+\vspace{1ex}
+Richard Kelsey ({\tt kelsey@corwin.ccs.northeastern.edu}) \\
+Jonathan Rees ({\tt jar@cs.cornell.edu}) \\
+June 1992
+\end{center}
+
+\vspace{1ex}
+
+Scheme 48 is an implementation of the Scheme programming language based
+on a virtual machine architecture.  The following is an overview of
+the project.
+
+\paragraph{Goals}
+
+\begin{itemize}
+\setlength{\itemsep}{0pt}
+\item Straightforward, minimal implementation.
+\item Flexible experimental apparatus for research in programming
+      language design and implementation.
+\item Easy to make changes to internal data representations, memory
+      management, and compilation strategy.
+\item High reliability.
+\item Fast and complete enough to be a good
+      development environment for Scheme programs.
+\end{itemize}
+
+
+\paragraph{Virtual machine}
+
+The virtual machine executes a simple byte-code instruction set
+similar to the target of the Scheme 311 compiler [Clinger, LFP 1984].
+The interpreter for the virtual instruction set is itself written in
+PreScheme, a systems programming dialect of Scheme.  A PreScheme
+compiler applies intensive source-to-source rewrites to the
+interpreter source code and emits low-level C code.  When the output
+is then compiled by an optimizing C compiler such as gcc, the result
+is a very efficient and portable emulator.
+
+\paragraph{Run-time system}
+
+The virtual machine is initialized from a specified memory image
+containing byte-compiled Scheme code and data.  Images (including
+small stand-alone applications) are built either by a linker or by
+writing out the state of an executing program.  A standard memory
+image contains a Scheme run-time library ({\tt append}, {\tt read},
+{\tt write}, etc.), a compiler from Scheme to the virtual instruction
+set, and a command processor and debugger.  In this way Scheme 48 can
+be configured to look like a conventional Lisp interpreter.
+
+In addition to the Scheme run-time library and development
+environment, library software includes support for multitasking,
+modules (packages), hygienic macros (as described in the Revised$^4$
+Scheme report), records, and exception handling.
+
+\paragraph{Applications}
+
+The Scheme 48 system is being used at several sites for research in
+memory management, embedded systems, multiprocessing, and computer
+system verification.  Scheme 48 was chosen as the platform for these
+projects because of its internal tractability and flexibility.
+
+\end{document}
diff --git a/doc/src/utilities.tex b/doc/src/utilities.tex
new file mode 100644
index 0000000..08f6da1
--- /dev/null
+++ b/doc/src/utilities.tex
@@ -0,0 +1,383 @@
+\documentclass{article}
+\usepackage{hyperlatex}
+
+\include{proto}
+
+% Make a few big HTML files, and not a lot of small ones.
+\setcounter{htmldepth}{1}
+
+\makeindex
+
+\title{Scheme 48 User's Guide}
+\author{Richard A. Kelsey}
+
+%\date{}
+
+\begin{document}
+
+\maketitle
+
+\section{ASCII character encoding}
+
+These are in the structure \code{ascii}.
+
+\begin{protos}
+\proto{char->ascii}{ char}{integer}
+\proto{ascii->char}{ integer}{char}
+\end{protos}
+\noindent
+These are identical to \code{char->integer} and \code{integer->char} except that
+ they use the ASCII encoding.
+
+\begin{protos}
+\constproto{ascii-limit}{integer}
+\constproto{ascii-whitespaces}{list of integers}
+\end{protos}
+\code{Ascii-limit} is one more than the largest value that \code{char->ascii}
+ may return.
+\code{Ascii-whitespaces} is a list of the ASCII values of whitespace characters
+ (space, tab, line feed, form feed, and carriage return).
+
+\section{Bitwise integer operations}
+
+These functions use the two's-complement representation for integers.
+There is no limit to the number of bits in an integer.
+They are in the structures \code{bitwise} and \code{big-scheme}.
+
+\begin{protos}
+\proto{bitwise-and}{ integer integer}{integer}
+\proto{bitwise-ior}{ integer integer}{integer}
+\proto{bitwise-xor}{ integer integer}{integer}
+\proto{bitwise-not}{ integer} {integer}
+\end{protos}
+\noindent
+These perform various logical operations on integers on a bit-by-bit
+basis. `\code{ior}' is inclusive OR and `\code{xor}' is exclusive OR.
+
+\begin{protos}
+\proto{arithmetic-shift}{ integer bit-count}{integer}
+\end{protos}
+\noindent Shifts the integer by the given bit count, which must be an integer,
+ shifting left for positive counts and right for negative ones.
+Shifting preserves the integer's sign.
+
+\section{Arrays}
+
+These are N-dimensional, zero-based arrays and
+ are in the structure \code{arrays}.
+
+The array interface is derived from one written by Alan Bawden.
+
+\begin{protos}
+\proto{make-array}{ value dimension$_0$ \ldots}{array}
+\proto{array}{ dimensions element$_0$ \ldots}{array}
+\proto{copy-array}{ array}{array}
+\end{protos}
+\noindent
+\code{Make-array} makes a new array with the given dimensions, each of which
+ must be a non-negative integer.
+Every element is initially set to \cvar{value}.
+\code{Array} Returns a new array with the given dimensions and elements.
+\cvar{Dimensions} must be a list of non-negative integers, 
+The number of elements should be the equal to the product of the
+ dimensions.
+The elements are stored in row-major order.
+\begin{example}
+(make-array 'a 2 3) \evalsto \{Array 2 3\}
+
+(array '(2 3) 'a 'b 'c 'd 'e 'f)
+    \evalsto \{Array 2 3\}
+\end{example}
+
+\code{Copy-array} returns a copy of \cvar{array}.
+The copy is identical to the \cvar{array} but does not share storage with it.
+
+
+\begin{protos}
+\proto{array?}{ value}{boolean}
+\end{protos}
+\noindent
+Returns \code{\#t} if \cvar{value} is an array.
+
+\begin{protos}
+\proto{array-ref}{ array index$_0$ \ldots}{value}
+\protonoresult{array-set!}{ array value index$_0$ \ldots}
+\proto{array->vector}{ array}{vector}
+\proto{array-dimensions}{ array}{list}
+\end{protos}
+\noindent
+\code{Array-ref} returns the specified array element and \code{array-set!}
+ replaces the element with \cvar{value}.
+\begin{example}
+(let ((a (array '(2 3) 'a 'b 'c 'd 'e 'f)))
+  (let ((x (array-ref a 0 1)))
+    (array-set! a 'g 0 1)
+    (list x (array-ref a 0 1))))
+    \evalsto '(b g)
+\end{example}
+
+\code{Array->vector} returns a vector containing the elements of \cvar{array}
+ in row-major order.
+\code{Array-dimensions} returns the dimensions of
+ the array as a list.
+
+\begin{protos}
+\proto{make-shared-array}{ array linear-map dimension$_0$ \ldots}{array}
+\end{protos}
+\noindent
+\code{Make-shared-array} makes a new array that shares storage with \cvar{array}
+ and uses \cvar{linear-map} to map indicies to elements.
+\cvar{Linear-map} must accept as many arguments as the number of
+ \cvar{dimension}s given and must return a list of non-negative integers
+ that are valid indicies into \cvar{array}.
+\begin{example}
+(array-ref (make-shared-array a f i0 i1 ...)
+           j0 j1 ...)
+\end{example}
+is equivalent to
+\begin{example}
+(apply array-ref a (f j0 j1 ...))
+\end{example}
+
+As an example, the following function makes the transpose of a two-dimensional
+ array:
+\begin{example}
+(define (transpose array)
+  (let ((dimensions (array-dimensions array)))
+    (make-shared-array array
+                       (lambda (x y)
+		         (list y x))
+		       (cadr dimensions)
+		       (car dimensions))))
+
+(array->vector
+  (transpose
+    (array '(2 3) 'a 'b 'c 'd 'e 'f)))
+      \evalsto '(a d b e c f)
+\end{example}
+
+\section{Records}
+
+New types can be constructed using the \code{define-record-type} macro
+ from the \code{define-record-types} structure
+The general syntax is:
+\begin{example}
+(define-record-type \cvar{tag} \cvar{type-name}
+  (\cvar{constructor-name} \cvar{field-tag} \ldots)
+  \cvar{predicate-name}
+  (\cvar{field-tag} \cvar{accessor-name} [\cvar{modifier-name}])
+  \ldots)
+\end{example}
+This makes the following definitions:
+\begin{protos}
+\constproto{\cvar{type-name}}{type}
+\proto{\cvar{constructor-name}}{ field-init \ldots}{type-name}
+\proto{\cvar{predicate-name}}{ value}{boolean}
+\proto{\cvar{accessor-name}}{ type-name}{value}
+\protonoresult{\cvar{modifier-name}}{ type-name value}
+\end{protos}
+\noindent
+\cvar{Type-name} is the record type itself, and can be used to
+ specify a print method (see below).
+\cvar{Constructor-name} is a constructor that accepts values
+ for the fields whose tags are specified.
+\cvar{Predicate-name} to a predicate that can returns \code{\#t} for
+ elements of the type and \code{\#f} for everything else.
+The \cvar{accessor-name}s retrieve the values of fields,
+ and the \cvar{modifier-name}'s update them.
+The \cvar{tag} is used in printing instances of the record type and
+ the field tags are used in the inspector and to match
+ constructor arguments with fields.
+
+\begin{protos}
+\protonoresult{define-record-discloser}{ type discloser}
+\end{protos}
+\noindent
+\code{Define-record-discloser} determines how
+ records of type \cvar{type} are printed.
+\cvar{Discloser} should be procedure which takes a single
+ record of type \cvar{type} and returns a list whose car is
+ a symbol.
+The record will be printed as the value returned by \cvar{discloser}
+ with curly braces used instead of the usual parenthesis.
+
+For example
+\begin{example}
+(define-record-type pare :pare
+  (kons x y)
+  pare?
+  (x kar set-kar!)
+  (y kdr))
+\end{example}
+ defines \code{kons} to be a constructor, \code{kar} and \code{kdr} to be
+ accessors, \code{set-kar!} to be a modifier, and \code{pare?} to be a predicate
+ for a new type of object.
+The type itself is named \code{:pare}.
+\code{Pare} is a tag used in printing the new objects.
+
+By default, the new objects print as \code{\#{Pare}}.
+The print method can be modified using DEFINE-RECORD-DISCLOSER:
+\begin{example}
+(define-record-discloser :pare
+  (lambda (p) `(pare ,(kar p) ,(kdr p))))
+\end{example}
+ will cause the result of \code{(kons 1 2)} to print as
+ \code{\#\{pare 1 2\}}.
+
+\section{Finite record types}
+
+The structure \code{finite-types} has
+ two macros for defining `finite' record types.
+These are record types for which there are a fixed number of instances,
+ which are created when the record type is defined.
+The syntax for the defining a finite type is:
+\begin{example}
+(define-finite-type \cvar{tag} \cvar{type-name}
+  (\cvar{field-tag} \ldots)
+  \cvar{predicate-name}
+  \cvar{vector-of-elements-name}
+  \cvar{name-accessor}
+  \cvar{index-accessor}
+  (\cvar{field-tag} \cvar{accessor-name} [\cvar{modifier-name}])
+  \ldots
+  ((\cvar{element-name} \cvar{field-value} \ldots)
+   \ldots))
+\end{example}
+This differs from \code{define-record-type} in the following ways:
+\begin{itemize}
+\item No name is specified for the constructor, but the field arguments
+ to the constructor are listed.
+\item The \cvar{vector-of-elements-name} is added; it will be bound
+ to a vector containing all of the elements of the type.
+These are constructed by applying the (unnamed) constructor to the
+ initial field values at the end of the form.
+\item There are names for accessors for two required fields, name
+ and index.
+These fields are not settable, and are not to be included
+ in the argument list for the constructor.
+\item The form ends with the names and the initial field values for
+ the elements of the type.
+The name must be first.
+The remaining values must match the \cvar{field-tag}s in the constructor's
+ argument list.
+\item \cvar{Tag} is bound to a macro that maps \cvar{element-name}s to the
+ the corresponding element of the vector.
+The name lookup is done at macro-expansion time.
+\end{itemize}
+
+\begin{example}
+(define-finite-type color :color
+  (red green blue)
+  color?
+  colors
+  color-name
+  color-index
+  (red   color-red)
+  (green color-green)
+  (blue  color-blue)
+  ((white  255 255 255)
+   (black    0   0   0)
+   (yellow 255 255   0)
+   (maroon 176  48  96)))
+
+(color-name (vector-ref colors 0)) \evalsto white
+(color-name (color black))         \evalsto black
+(color-index (color yellow))       \evalsto 2
+(color-red (color maroon))         \evalsto 176
+\end{example}
+
+Enumerated types are finite types whose only fields are the name
+ and the index.
+The syntax for defining an enumerated type is:
+\begin{example}
+(define-enumerated-type \cvar{tag} \cvar{type-name}
+  \cvar{predicate-name}
+  \cvar{vector-of-elements-name}
+  \cvar{name-accessor}
+  \cvar{index-accessor}
+  (\cvar{element-name} \ldots))
+\end{example}
+In the absence of any additional fields, both the constructor argument
+ list and the initial field values are not required.
+
+The above example of a finite type can be pared down to the following
+ enumerated type:
+\begin{example}
+(define-enumerated-type color :color
+  color?
+  colors
+  color-name
+  color-index
+  (white black yellow maroon))
+
+(color-name (vector-ref colors 0)) \evalsto white
+(color-name (color black))         \evalsto black
+(color-index (color yellow))       \evalsto 2
+\end{example}
+
+\section{Hash tables}
+
+These are generic hash tables, and are in the structure \code{tables}.
+Strictly speaking they are more maps than tables, as every table has a
+ value for every possible key (for that type of table).
+All but a finite number of those values are \code{\#f}.
+
+\begin{protos}
+\proto{make-table}{}{table}
+\proto{make-symbol-table}{}{symbol-table}
+\proto{make-string-table}{}{string-table}
+\proto{make-integer-table}{}{integer-table}
+\proto{make-table-maker}{ compare-proc hash-proc}{procedure}
+\protonoresult{make-table-immutable!}{ table}
+\end{protos}
+\noindent
+The first four functions listed make various kinds of tables.
+\code{Make-table} returns a table whose keys may be symbols, integer,
+ characters, booleans, or the empty list (these are also the values
+ that may be used in \code{case} expressions).
+As with \code{case}, comparison is done using \code{eqv?}.
+The comparison procedures used in symbol, string, and integer tables are
+ \code{eq?}, \code{string=?}, and \code{=}.
+
+\code{Make-table-maker} takes two procedures as arguments and returns
+ a nullary table-making procedure.
+\cvar{Compare-proc} should be a two-argument equality predicate.
+\cvar{Hash-proc} should be a one argument procedure that takes a key
+ and returns a non-negative integer hash value.
+If \code{(\cvar{compare-proc} \cvar{x} \cvar{y})} returns true,
+ then \code{(= (\cvar{hash-proc} \cvar{x}) (\cvar{hash-proc} \cvar{y}))}
+ must also return true.
+For example, \code{make-integer-table} could be defined
+ as \code{(make-table-maker = abs)}.
+
+\code{Make-table-immutable!} prohibits future modification to its argument.
+
+\begin{protos}
+\proto{table?}{ value}{boolean}
+\proto{table-ref}{ table key}{value or \code{\#f}}
+\protonoresult{table-set!}{ table key value}
+\protonoresult{table-walk}{ procedure table}
+\end{protos}
+\noindent
+\code{Table?} is the predicate for tables.
+\code{Table-ref} and \code{table-set!} access and modify the value of \cvar{key}
+ in \cvar{table}.
+\code{Table-walk} applies \cvar{procedure}, which must accept two arguments,
+ to every associated key and non-\code{\#f} value in \code{table}.
+
+\begin{protos}
+\proto{default-hash-function}{ value}{integer}
+\proto{string-hash}{ string}{integer}
+\end{protos}
+\noindent
+\code{default-hash-function} is the hash function used in the tables
+ returned by \code{make-table}, and \code{string-hash} it the one used
+ by \code{make-string-table}.
+
+%\W \chapter*{Index}
+%\W \htmlprintindex
+%\T \input{doc.ind}
+
+\end{document}
+
+
diff --git a/doc/threads.txt b/doc/threads.txt
new file mode 100644
index 0000000..393f006
--- /dev/null
+++ b/doc/threads.txt
@@ -0,0 +1,87 @@
+
+			       Threads
+
+The following are exported by the THREADS structure.
+
+(SPAWN thunk)
+(SPAWN thunk name)
+  Create and schedule a new thread that will execute <thunk>.  The optional
+  name is used when printing the thread.
+
+(RELINQUISH-TIMESLICE)
+  Let other threads run for a while.
+
+(SLEEP time)
+  Sleep for <time> milliseconds.
+
+(TERMINATE-CURRENT-THREAD)
+  Kill the current thread.
+
+(THREAD? thing)
+  #T if thing is a thread, #F otherwise.
+
+(THREAD-NAME thread)
+(THREAD-UID thread)
+  For printing debugging information.
+
+-----
+
+The following are exported by the LOCKS structure.
+
+(MAKE-LOCK) => lock
+(OBTAIN-LOCK lock)
+(RELEASE-LOCK lock)
+  Locks are semaphores.
+
+-----
+
+The following are exported by the PLACEHOLDERS structure.
+
+(MAKE-PLACEHOLDER) => placeholder
+(PLACEHOLDER-VALUE placeholder) => value of placeholder
+(PLACEHOLDER-SET! placeholder value)
+(PLACEHOLDER? thing) => #t or #f
+  Attempts to reference a placeholder before it has been set cause the
+  referencing thread to block.  Setting a placeholder to two different
+  values is an error.  (Previous versions of Scheme 48 called these
+  `condition variables', which turn out to be somewhat different.)
+
+-----
+
+Threads and the command interpreter.
+
+Each level of the command interpreter has its own set of active
+threads.  Moving to a new level, for example when an error occurs,
+halts all threads belonging to the previous level.  Resuming the
+a level causes its associated threads to continue running.
+
+The ,threads command inspects the threads running in the stopped
+command level.
+
+
+    > ,open threads
+    > (define (foo) (sleep 1000) (display "Hi") (newline) (foo))
+    > (spawn foo 'my-thread)
+    > Hi
+    (begin (sleep 10000) (display "Done") (newline))
+    Hi
+    
+    Interrupt: keyboard
+    1> (sleep 5000)
+    ; note that the Hi thread doesn't run in this command level
+    1> ,proceed 0
+    Hi
+    ; but it resumes when we resume this level
+    Hi
+    Done
+    > Hi
+    Hi
+    Hi
+    
+    Interrupt: keyboard
+    1> ,threads
+    '(#{Thread 28 my-thread} #{Thread 27 command-loop})
+    
+     [0] '#{Thread 28 my-thread}
+     [1] '#{Thread 27 command-loop}
+    inspect: 
diff --git a/doc/todo.txt b/doc/todo.txt
new file mode 100644
index 0000000..e9e79c3
--- /dev/null
+++ b/doc/todo.txt
@@ -0,0 +1,243 @@
+--*- Mode: Indented-text; -*-
+
+Scheme 48: list of bugs and things to do.
+Last update by RAK on 28 April 1998.
+
+Run-time system bugs:
+    Shadowing can fail sometimes for macro-referenced variables.  E.g.
+      the following sequence will lose if entered interactively as
+      three separate forms:
+        (define (foo x) `(a ,x))
+	(define cons list)
+	(foo 1) => (a (1 ()))
+
+Programming environment:
+    Fuller on-line documentation.
+    Error recovery.  Can do better than ,proceed.  LOAD should set up
+      restart continuations.
+    Types in scheme-interface (and elsewhere) aren't as tight as they
+      could be.
+    LET continuation "pessimization" to retain the environment longer.
+    Have the disassembler display local variable names.
+    This ought to be recoverable, but isn't always:
+	> (let loop ((x '())) (loop (cons 3 x)))
+	not enough room in heap for stack
+    The get-cont-from-heap instruction should have an exception
+      discloser that indicates the actual error (returning a
+      non-fixnum from application top level).
+    Separate compilation (compile a module, writing object code to a
+      file).  (Rudiments in misc/separate.scm)
+    Semicolon comments don't quite work after commands (extra newline
+      required).
+    Command (and procedure) to change current directory.
+    Some procedure in EXEC to take the place of ## in moving values from
+      one package to another: (transport <from-package> <exp> <to-package>
+      [<id>]), and/or have eval etc. commands return the value
+    Batch mode should write error messages to (error-output).
+
+Performance:
+    Generational GC.
+    More compact representation for debugging data?
+    Leaf procedure compilation (RK's rts/no-leaf-env.scm): if no
+      continuations or lambdas, skip the make-env and access locals
+      using stack-ref.  Expected to gain about 6% in speed.
+    Optimize loops somehow (maybe using call-template opcode and/or
+      opportunistic compilation).
+    The CAML light implementation has good documentation and patches
+      for optimizing the interpreter's switch (*pc++); perhaps we
+      could lift some of it.  (Range check isn't necessary.)
+    Floating point support in VM.
+    Bignum support in VM: use MIT Scheme bignums or GNU Multiple
+      Precision Arithmetic Library (Torbjorn Granlund <tege@sics.se>).
+    Faster bignum printer (e.g. the one Richard wrote - but it would be
+      nice if it were an option tied to bignums, not built in to the
+      initial image).
+    Ratnum multiplication and division might be made more efficient by
+      taking cross-GCD's.
+    Native code compiler...
+
+Big Scheme bugs / features:
+    It would be nice to be able to simulate control-C interrupts on
+      a port other than the initial input port - e.g., on a socket.
+      This would require creating a new thread to act as a front end.
+      The new thread would read characters eagerly, buffering
+      everything except control-C's for the thread that is doing the
+      real work, and converting control-C's into interrupts.
+    How about deleting entries from tables?
+    RPC.
+    Add call/gcc (invokes the Gnu C compiler).
+
+Module system bugs:
+    ,untrace should undefine as well if the variable wasn't bound
+      before.
+    Compound signatures don't get updated when a component signature
+      changes.  They contain a list of signatures with no reinitialization
+      thunk a la structures and packages.
+
+Module system features:
+    Check for name conflicts between opened structures.
+    Implement interface subtraction as a way of dealing with such
+      conflicts: (WITHOUT (<name> ...) <interface>)
+    Check for cycles in structure inheritance.
+    An ,access command, similar to ,open.
+    Deal with package system state better (for linker).  Maybe each
+      package should point to a data structure containing
+      *location-uid*, location-name-table, *package-uid*,
+      package-name-table, and perhaps the compiler-state as well (see
+      segment.scm).
+
+VM:
+    Heaps that can grow larger.
+    Add a test to configure.in that can determine whether ld -A works.
+      If both it and dlopen() work, then both kinds of dynamic loading
+      should be made available.
+    Merge in Olin's changes and extensions (command line processing,
+      the #! syntax for scripts, external function call, etc.).
+    Interrupt while writing out image causes an exit.  [Fixed?]
+    A jump-back instruction?  Might be easier to use than call-template.
+    Scrutinize all VM fatal errors to see if any can be recovered
+      from.  E.g. "out of ports" shouldn't cause a VM halt, it should
+      just cause open-port to return #f or an error code.  [Fixed?]
+    Get VM interp.scm-without-gc.scm working again.
+
+Documentation:
+    Describe (optimize auto-integrate).
+    How to use the static linker.
+    How initial.image and scheme48.image get built, really.
+    Techniques for debugging the runtime system (debug/for-debugging.scm).
+
+Cleanup:
+  VM:
+    Rename "unassigned" to "uninitialized"?  Or phase it out entirely.
+    In unix.c, use getrusage(), when available, to get run time.
+  Run-time / features / development environment:
+    A DIVIDE procedure (maybe an instruction as well) that returns two
+      values.
+    Figure out how to merge the two type systems (META-METHODS and
+      META-TYPES).  The generic function system could make use of the
+      SUBTYPE? and INTERSECT? predicates.
+    Correct floating point, esp. reading and printing.  And
+      (= 1/3 (/ 1. 3.)) returns #t, but ought to return #f.
+    Parameterize over file name syntax somehow.  Currently
+      big/filename.scm assumes Unix (cf. DIRECTORY-COMPONENT-SEPARATOR,
+      FILE-NAME-PREFERRED-CASE).  Perhaps there should be VM support for
+      this.
+    Make sure that the disassembler and assembler are inverses of one
+      another.
+    Disassembler should generate S-expression first, and then print
+      it independently.
+    Combine conditions, signals, and handle into a single structure?
+    Figure out a better way to implement ##.
+    Be consistent about "filename" versus "file-name".
+  Compiler / linker / module system:
+    The "reflective tower" isn't really a reflective tower, it's a
+      syntactic tower.  Rename it.
+    The scanner (file loader) should operate on streams, not lists.
+      This would result in more uniform and flexible internal
+      protocols for reading files, scanning for DEFINEs, compiling,
+      and running - passes could be interleaved or separated easily.
+    Flush link/data.scm.  Linker should instead open the VM module
+      that includes vm/data.scm.
+    Flush (optimize ...) clause in DEFINE-STRUCTURE in favor of
+      optimizer argument to SCAN-STRUCTURES.
+    Vector patterns and templates ought to be supported in
+      SYNTAX-RULES.
+    The DEFINE-INTERFACE forms should contain types for every exported
+      variable; the code in cprim.scm (and recon.scm?) shouldn't have
+      to worry about setting up types.
+    Add ENVIRONMENT-DEFINED? ?
+    Make USUAL-TRANSFORM return a transform?
+    Add enough to the node signature to make it usable on its own?
+    make-c-header-file should put definitions for the interrupt
+      enumeration into scheme48.h, and unix.c et al should use them.
+    Flatloading and loading are very different operations, so FLATLOAD
+      shouldn't do SET-PACKAGE-LOADED?!; instead it should maintain its
+      own list of flatloaded packages (in a global variable, say).
+  Etc:
+    Start using a source control system (like rcs).
+    There ought to be a sanity check to ensure that the size of the
+      area as computed by static.scm agrees with the size as computed
+      by C's sizeof() operator.
+
+What should (syntax-rules (x) ((foo ?body) (let ((x 1)) ?body))) do?
+
+
+To: jar@cs.cornell.edu
+Subject: Not a bug this time. :-)
+Date: Tue, 22 Feb 94 19:13:37 -0500
+From: Paul Stodghill <stodghil@cs.cornell.edu>
+
+The result of ,expand can be confusing. In particular, it doesn't
+distinguish between different identifiers that have the same name.
+
+For instance, in the example below, it would be more useful if the result
+of the ,expand was something like,
+
+	'((lambda (.x.1) (set! x (- .x.1))) x)
+
+Welcome to Scheme 48 0.31 (made by jar on Sun Feb 13 18:33:57 EST 1994).
+Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees.
+Please report bugs to scheme-48-bugs@altdorf.ai.mit.edu.
+Type ,? (comma question-mark) for help.
+> (define-syntax foo
+    (syntax-rules ()
+      ((foo var) ((lambda (x) (set! var (- x))) var))))
+> (define x 1)
+> ,expand (foo x)
+'((lambda (x) (set! x (- x))) x)
+> 
+
+
+
+Date: Mon, 14 Jun 93 18:33:30 HKT
+From: shivers@csd.hku.hk
+To: kelsey@flora.ccs.neu.edu
+Cc: jar@cs.cornell.edu
+Subject: Scheme 48
+
+...
+All true.  My major motivation was portability. I also found the module system
+to be a big win. Other things that influenced me were (1) elegance and
+modularity -- I felt I could comprehend and mung the system as needed (2)
+reasonable efficiency and small size and (3) real, full R4RS+ support (most
+small systems do it partly).
+
+Actually, I wouldn't say the programming environment is particularly
+exceptional, unless you count the module system.
+
+A small thing lacking in other Schemes that really reduced my debug times: the
+loader would complain about undefined free var refs in my code. This
+frequently picked out variable spelling errors, inconsistent name linkages,
+and forgotten procedure defs. Not a big thing, but really effective.
+
+Another win was simply having the implementors around for detailed
+explanations and support.
+
+Problems I had with S48: 
+- Inability to mess with the VM, as it is written in a language that can
+  be compiled by only 1 person in the world.
+
+- The foreign-function support was quite limited, and the foreign-data support
+  was basically non-existent. Exporting gc'd data to C, gc'ing data allocated
+  in C, hooks into the GC, importing C data into Scheme -- no support.  Elk
+  handles this better, as that is critical to the type of applications at
+  which elk is targeted.
+
+  I fixed some of this myself -- helped by your general, portable low-level ff
+  interface, which was well-designed in terms of those goals -- but I couldn't
+  do much about foreign-data support.
+
+- No support currently for linking static heap data into a text-pages
+  area to reduce gc copying and shrink the dynamic heap.
+
+- The module system was frequently frustrating. The non-uniform , command 
+  language, bugs, the restrictions of living with a module system,
+  being blocked from accessing primitives whose bindings had been
+  gc'd away at link time, and awkwardnesses in the user interface really
+  slowed me down.
+
+  The module system was also a great help; these are simply the problems
+  of life with an experimental system, as opposed to a polished final
+  product.
+
+[But] all in all, S48 was the best choice I could have made.  
diff --git a/doc/type.txt b/doc/type.txt
new file mode 100644
index 0000000..1aa60f6
--- /dev/null
+++ b/doc/type.txt
@@ -0,0 +1,240 @@
+
+			   The Type System
+
+
+Scheme 48 has a rudimentary type system.  Its main purpose is to
+generate helpful compile-time diagnostics.
+
+Currently you don't get much checking beyond wrong number of arguments
+warnings unless you're compiling a package that has an (OPTIMIZE ...)
+clause in its definition (e.g. (OPTIMIZE EXPAND) or (OPTIMIZE
+AUTO-INTEGRATE)).  The reason that type checking is disabled most of
+the time is that it increases compilation time by about 33%.
+
+A design goal is to assign types to all valid Scheme programs.  That
+is, type warnings should not be generated for programs that could work
+according to Scheme's dynamic semantics.  For example, no warning
+should be produced for
+
+    (define (foo x y) (if x (+ y 1) (car y)))
+
+Warnings could in principle be produced for particular calls to FOO
+that would definitely go wrong, such as (foo #t 'a).
+
+The type system assumes that all code is potentially reachable.  This
+means that there will be some warnings for programs that cannot go
+wrong, e.g. (if #t 3 (car 7)).
+
+Additionally, it's assumed that in a (BEGIN ...) or combination, every
+argument or command will always be executed.  This won't be the case
+if there can be a throw out of the middle.  For example, in
+
+    (call-with-current-continuation
+      (lambda (k)
+        (if (not (number? x))
+	    (k #f))
+        (+ x 1)))
+
+the type system might deduce that X must be a number (which is false).
+
+The type reconstruction algorithm (such as it is) is in
+bcomp/recon.scm.  The implementation finds some specific procedure
+types for LAMBDA expressions, but generally gives up pretty quickly.
+
+Notation
+--------
+
+F : T means that form F has static type T.  T1 <= T2, or T1 is under
+T2, means that T1 is a subtype of T2; that is, if a form of type T2 is
+acceptable in some context, then so is a form of type T1.
+
+Non-expressions
+---------------
+
+Not every valid Scheme form is an expression.  Forms that are not
+expressions are syntactic keywords, definitions, types, and structure
+names.
+
+If a name is bound to a macro or special operator, then an occurrence
+of that name has type :SYNTAX.  E.g.
+
+    cond : :syntax
+
+Definitions have type :DEFINITION.  E.g.
+
+    (begin (define x 1) (define y 2)) : :definition
+
+Thus type checking subsumes syntax checking.
+
+Types (other than :TYPE itself?) have type :TYPE.
+
+The type of a structure is its interface.  E.g.
+
+    (define-structure foo (export a b) ...)
+    foo : (export a b)
+
+Values
+------
+
+All expressions have type :VALUES.  They may have more specific
+types as well.
+
+If E1 ... En have types T1 ... Tn with Ti <= :VALUE, then
+the expression (VALUES E1 ... En) has type (SOME-VALUES T1 ... Tn).
+
+If T <= :VALUE then (SOME-VALUES T) is equivalent to T.
+
+Procedure types
+---------------
+
+Procedure types have the form (PROCEDURE T1 T2), where T1 and T2 are
+under :VALUES.  Examples:
+
+    (lambda (x) (values x 1)) :
+       (procedure (some-values :value) (some-values :value :number))
+
+    cons : (procedure (some-values :value :value) :pair)
+
+Fixed-arity procedure types (PROCEDURE (SOME-VALUES T1 ... TN) T) are
+so common that the abbreviated syntax (PROC (T1 ... Tn) T) is
+defined to mean the same thing.  E.g.
+
+    cons : (proc (:value :value) :pair)
+
+E : (PROCEDURE T1 T2) means that in a call to a value of E, if the
+argument sequence has any type other than T1, then the call can be
+expected to "go wrong" (provoke a type error) at run time.  This is
+not to say it will definitely go wrong, but that it is just a matter
+of luck if it doesn't.  If the argument sequence does have type T1,
+then the call might or might not go wrong, and any return value(s)
+will have type T2.
+
+For example,
+
+    (lambda (x) (+ (begin (set! x '(3)) 5) (car x))) :
+       (proc (:pair) :value),
+
+because if the arguments to + are evaluated from right to left, and X
+is not a pair, then there will be a run time type error.
+
+Some primitive procedures have their own special typing rules.
+Examples include VALUES, CALL-WITH-VALUES, and PRIMITIVE-CATCH.
+
+Variable types
+--------------
+
+Assignable variables have type (VARIABLE T), where T for now will
+always be :VALUE.  In (SET! V E), V must have type (VARIABLE T) for
+some T.
+
+Loopholes
+---------
+
+The construct (loophole T E) is considered to have type T no matter
+what type E has.  Among other things, this allows a rudimentary static
+abstract data type facility.  For example, record types defined using
+DEFINE-RECORD-TYPE (rts/bummed-jar-defrecord.scm) are established as
+new base types.
+
+Type lattice
+------------
+
+The subtype relation is implemented by the procedure COMPATIBLE-TYPES?
+(in bcomp/mtypes.scm).  If (COMPATIBLE-TYPES? T1 T2) is 'definitely,
+then T1 <= T2.  If it's #T, then T1 and T2 intersect.
+
+The type lattice has no bottom or top elements.
+
+The types :SYNTAX, :VALUES, :DEFINITION, :STRUCTURE, and :TYPE are
+incomparable and maximal.
+
+The following are a comprehensive set of subtyping rules for the type
+system as it stands.  Additional rules may be added in the future.
+
+   - (SOME-VALUES T1 ... Tn) <= :VALUES.
+
+   - If T1 <= T1', ..., Tn <= Tn' then (SOME-VALUES T1 ... Tn) <=
+     (SOME-VALUES T1' ... Tn').
+
+   - T <= (SOME-VALUES T).
+
+   - Basic value types, which include :NUMBER, :CHAR, :BOOLEAN, :PAIR,
+     :STRING, and :UNSPECIFIC, are all under :VALUE.
+
+   - If T1' <= T1 and T2 <= T2', then (PROCEDURE T1 T2) <= (PROCEDURE
+     T1' T2').
+
+   - (VARIABLE T) <= T.
+
+   - :ZERO, the result type of infinite loops and calls to
+     continuations, is under :VALUE, but perhaps shouldn't be.  (E.g.
+     maybe it should be just under :VALUES instead.)
+
+   - (EXPORT (<name> T) ...) is under :STRUCTURE.
+     [Not yet implemented.]
+
+Type well-formedness
+--------------------
+
+In (SOME-VALUES T1 ... Tn), T1 ... Tn must be under :VALUE.
+
+In (PROCEDURE T1 T2), T1 and T2 must be under :VALUES.
+
+In (VARIABLE T), T must be under :VALUE.
+
+Module system
+-------------
+
+The rules for interfaces and structures are not yet very well worked
+out.
+
+Interfaces are types.  The type of a structure is its interface.
+(Compare with Pebble's "bindings" and "declarations".)
+
+An interface has the basic form (EXPORT (<name> <type>) ...).
+There are two kinds of abbreviations:
+  - (EXPORT ... <name> ...) means the same as
+    (EXPORT ... (<name> :VALUE) ...)
+  - (EXPORT ... ((<name1> <name2> ...) <type>) ...) means the same as
+    (EXPORT ... (<name1> <type>) (<name2> <type>) etc. ...)
+
+Distinct interfaces are not comparable.
+
+If a form S has type (EXPORT ... (name T) ...), then the form
+(STRUCTURE-REF S name) has type T.  Note that T needn't be a :VALUE
+type; e.g.
+
+    (structure-ref scheme cond) : :syntax
+
+When a package is loaded or otherwise compiled, the type that is
+reconstructed or inherited for each exported name is checked against
+the type specified in the signature.  (Cf. procedure SCAN-STRUCTURES
+in bcomp/scan.scm.)
+
+<explain the role of the expander in type checking... compile-call
+doesn't do much checking if the arguments aren't expanded...>
+
+Future work
+-----------
+
+There probably ought to be dependent sums and products and/or
+universal and existential types.  In particular, it would be nice to
+be able to get static checking for abstract types, even if they're not
+implemented using records.
+
+Type constructors (like STREAM-OF or COMPUTATION-OF) would be nice.
+
+There are many loose ends in the implementation.  For example, type
+and type constructor names aren't always lexically scoped; sometimes
+their scope is global.  Packages that open the LOOPHOLES structure
+(which exports LOOPHOLE) don't always open TYPES (which would be a bad
+idea given the way TYPES is currently defined); LOOPHOLE works in
+spite of that.
+
+Figure out whether :TYPE : :TYPE.
+
+
+-----
+
+Original by JAR, 20 July 93.
+Updated by JAR, 5 December 93.
diff --git a/doc/user-guide.txt b/doc/user-guide.txt
new file mode 100644
index 0000000..ff1fd15
--- /dev/null
+++ b/doc/user-guide.txt
@@ -0,0 +1,709 @@
+
+
+		     A User's Guide to Scheme 48
+
+
+
+    A line may take us hours, yet if it does not seem a moment's thought
+    All our stitching and unstitching has been as nought.
+
+    						Yeats
+    						Adam's Curse
+
+
+Introduction
+
+Scheme 48 is an implementation of the Scheme programming language as
+described in the Revised^4 Report on the Algorithmic Language Scheme.
+It is based on a compiler and interpreter for a virtual Scheme
+machine.  The name derives from our desire to have an implementation
+that is simple and lucid enough that it looks as if it were written in
+just 48 hours.  We don't claim to have reached that stage yet; much
+more simplification is necessary.
+
+Scheme 48 tries to be faithful to the upcoming Revised^5 Scheme
+Report, providing neither more nor less in the initial user
+environment.  (This is not to say that more isn't available in other
+environments; see below.)  Support for numbers is weak: bignums are
+slow and floating point is almost nonexistent (see description of
+floatnums, below).  DEFINE-SYNTAX, LET-SYNTAX, LETREC-SYNTAX, and
+SYNTAX-RULES are supported, but not the rest of the Revised^4 Scheme
+macro proposal.
+
+The Revised^5 Report hasn't been published yet, but it will be very
+similar to the Revised^4 Report.  For a list of differences, see
+doc/meeting.tex.
+
+This is what might be called an alpha release.  Please report bugs,
+especially in the VM, especially core dumps, to
+scheme-48-bugs@altdorf.ai.mit.edu.  Include the version number x.yy
+from the "Welcome to Scheme 48 x.yy" greeting message in your bug
+report.  It is a goal of this project to produce a bullet-proof
+system; we want no bugs and, especially, no crashes.  (There are a few
+known bugs, listed in the TODO file that comes with the distribution.)
+
+Send mail to scheme-48-request@altdorf.ai.mit.edu to be put on a
+mailing list for announcements, discussion, bug reports, and bug
+fixes.
+
+-----
+
+Command line arguments
+
+A few command line arguments are processed by the virtual machine as
+it starts up.
+
+    scheme48 [-i image] [-h heapsize] [-o filename] [-s stacksize]
+          [-a argument ...]
+
+-i image
+    specifies a heap image file to resume.  This defaults to a heap
+    image that runs a Scheme command processor.  Heap images are
+    created by the ,dump and ,build commands, for which see below.
+
+-h heapsize
+    specifies how much space should be reserved for allocation.
+    Heapsize is in words (where one word = 4 bytes), and covers both
+    semispaces, only one of which is in use at any given time (except
+    during garbage collection).  Cons cells are currently 3 words, so
+    if you want to make sure you can allocate a million cons cells,
+    you should specify -h 6000000 (actually somewhat more than this,
+    to account for the initial heap image and breathing room).
+
+-s stacksize
+    specifies how much space should be reserved for the continuation
+    and environment stack.  If this space is exhausted, continuations
+    and environments are copied to the heap.  stacksize is in words
+    and defaults to 2500.
+
+-o filename
+    This specifies an executable file in which foreign identifiers can be
+    looked up for the foreign function interface.  Filename should be the
+    file that contains the scheme48vm executable image.  See
+    doc/external.txt.
+
+-a argument ...
+    is only useful with images built using ,build.  The arguments are
+    passed as a list to the procedure specified in the ,build command.
+    E.g.
+
+        > ,build (lambda (a) (for-each display a) (newline) 0) foo.image
+	> ,exit
+	% scheme48vm -i foo.image -a mumble "foo x"
+	mumblefoo x
+	% 
+
+The usual definition of the "s48" or "scheme48" command is actually a
+shell script that starts up the virtual machine with a -i argument
+specifying the development environment heap image, and a -o argument
+specifying the location of the virtual machine.
+
+-----
+
+Command processor
+
+When you invoke the default heap image, a command processor starts
+running.  At the > prompt, you can type either a Scheme form
+(expression or definition), or a command beginning with a comma.
+
+Logistical commands:
+
+ ,load <filename> ...                load Scheme source file(s)
+    Easier to type than (load "filename") because you don't have to
+    shift to type the parentheses or quote marks.  Also, it works in
+    any package, unlike (load "filename"), which will work only work
+    in packages in which the variable LOAD is defined properly.
+
+ ,exit [<exp>]			     leave
+    Exit back out to shell (or executive or whatever invoked Scheme 48
+    in the first place).  <exp> should evaluate to an integer.  The
+    integer is returned to the calling program.  (On Unix, 0 is
+    generally interpreted as success, nonzero as failure.)
+
+
+Command levels:
+
+  If an errors occurs, you are put in a command loop at the dynamic
+  point at which the error occurred.  The prompt will then be "n >"
+  where n is the command level nesting depth.
+  
+ <eof> 
+    Pop out one level (running any dynamic-wind "after" thunks), and
+    resumes running all non-broken threads.  EOF after a keyboard
+    interrupt resumes running the interrupted thread.  <eof> is usually
+    control-D at a Unix shell or using the Emacs "cmuscheme48" library.
+
+ ,reset                              top level
+    Unwind all the way back out to top level.
+
+ ,level <number>                     go to command level
+    Unwind out to a given level.  ,level 0 is the same as ,reset.
+
+ ,push
+    Go to a deeper command level.  (See ,levels, below.)
+
+
+Debugging commands:
+
+ ,preview
+    Sort of like a backtrace, but because of tail recursion you see
+    less than you might in debuggers for some other languages.
+
+ ,threads
+    Invoke the inspector on the threads running on the next level out.
+
+ ,proceed <exp> ...
+    Proceed after an interrupt or error, delivering the values of <exp>
+    ... to the continuation.
+
+ ,trace <name> ...
+    Start tracing calls to the named procedure or procedures.
+    With no arguments, displays all procedures currently traced.
+    This affects the binding of <name>, not the behavior of the
+    procedure that's it's current value.  The effect is similar to
+	(define <name> (make-traced <name>))
+    where make-traced is a procedure-returning procedure.
+
+ ,untrace <name> ...
+    Stop tracing calls to the named procedure or procedures.
+    With no argument, stop tracing all calls to all procedures.
+
+ ,condition
+    The ,condition command selects and displays the condition object
+    describing the error or interrupt that initiated the current
+    command level.  This is particularly useful in conjunction with
+    the inspector.  E.g. if a procedure is passed the wrong number of
+    arguments, do ,condition followed by ,inspect ## to inspect the
+    procedure and its arguments.
+
+ ,bound? <name>
+    Display the binding of <name>, if there is one.
+ 
+ ,expand <form>
+    Show macro expansion of <form>, if any.
+
+ ,where <procedure>
+    Display name of source file in which <procedure> is defined.
+
+
+Building images:
+
+ ,dump <filename> [<identification>]
+    This writes out the current heap.  When the new image is resumed,
+    it starts in the command processor.  If present, <identification>
+    should be a string (written with double quotes); this string will
+    be part of the greeting message as the image starts up.
+
+ ,build <exp> <filename>
+    <exp> should evaluate to a procedure of one argument.  When
+    <filename> is resumed, that procedure will be invoked on the VM's
+    -a arguments, which are passed as a list of strings.  The
+    procedure should return an integer (as for ,exit).  The command
+    processor and debugging system are not included in the image
+    (unless you go to some effort to preserve them, such as retaining
+    a continuation).
+
+    Doing ",flush" before building an image will make for smaller
+    images, but if an error occurs, the error message may be less
+    helpful.  Doing ",flush source maps" before loading any programs
+    will make the image still smaller.
+    
+
+
+Modes:
+
+When given no argument, all of these commands toggle the corresponding
+mode.  With the argument ?, the current setting is displayed.
+Otherwise the argument should be ON or OFF.
+
+ ,batch [on | off | ?]
+    In "batch mode," any error or interrupt that comes up will cause
+    Scheme 48 to exit immediately with a non-zero exit status.  Also,
+    the command processor doesn't print prompts.  The default is
+    interactive mode.
+
+ ,form-preferred [on | off | ?]
+    Enable or disable "form preferred" mode.  In this mode, command
+    processor commands needn't be prefixed by comma.  To see the value
+    of a variable (or number - this should be fixed), do (begin
+    <name>).  "Command preferred" mode is the default.
+
+ ,levels [on | off | ?]
+    Enable or disable command levels.  With levels enabled (the
+    default), errors "push" a new command level, and <eof> (see above)
+    or ,reset is required to return to top level.  The effects of
+    pushed command levels include:
+      - a longer prompt
+      - retention of the continuation in effect at the point of errors
+      - longer ,previews
+      - confusion among some newcomers
+    With levels disabled, one must issue a ,push command immediately
+    following an error in order to retain the error continuation for
+    debugging purposes; otherwise the continuation is lost after the
+    next evaluation request.  If you don't know anything about the
+    available debugging tools, then levels might as well be disabled.
+
+    This is an experimental feature inspired by gripes about how
+    confusing recursive command loop levels are to newcomers to
+    Scheme.  Let me know (jar@ai.mit.edu) if you like it; otherwise it
+    might get flushed.
+
+    Each level has its own set of threads, so pushing a new level stops
+    all threads running at the current level.
+    
+ ,break-on-warnings [on | off | ?]
+    When a warning is produced, enter a new command level, just as
+    when an error occurs.
+
+
+Resource query and control:
+
+ ,time <exp>
+    Measure execution time.
+
+ ,collect
+    Invoke the garbage collector.  Ordinarily this happens
+    automatically, but the command tells how much space is available
+    before and after the collection.
+
+ ,keep <kind>
+ ,flush <kind>
+    These control the amount of debugging information retained after
+    compiling procedures.  This information can consume a fair amount
+    of space.  <kind> is one of the following:
+     . maps - environment maps (local variable names, for inspector)
+     . source - source code for continuations (displayed by inspector)
+     . names - procedure names (as displayed by WRITE and in error
+       messages)
+     . files  - source file names
+    These commands refer to future compilations only, not to procedures
+    that already exist.  To have any effect, they must be done before
+    programs are loaded.
+
+ ,flush
+    The flush command with no argument deletes the database of names
+    of initial procedures.  Doing ",flush" before a ,build or ,dump
+    will make the resulting image significantly smaller (by up to 200K
+    bytes), but will compromise the information content of many error
+    messages.
+
+
+Quite obscure:
+
+ ,go <exp>
+    This is like ,exit <exp> except that the evaluation of <exp>
+    is tail-recursive with respect to the command processor.  This
+    means that the command processor itself can probably be GC'ed,
+    should a garbage collection occur in the execution of <exp>.
+    Any errors will be treated as in batch mode.
+
+ ,translate <from> <to>
+    For LOAD and the ,load command (but not for OPEN-xxPUT-FILE), file
+    names beginning with the string <from> will be changed so that the
+    initial <from> is replaced by the string <to>.  E.g.
+
+        ,translate /usr/gjc/ /zu/gjc/
+
+    will cause (load "/usr/gjc/foo.scm") to have the same effect as
+    (load "/zu/gjc/foo.scm").
+
+ ,from-file <filename> <form> ... ,end
+    This is used by the cmuscheme48 Emacs library.
+
+Other commands are (or should be) described in the module system
+document.
+
+-----
+
+Editing
+
+We recommend running Scheme 48 under Gnu Emacs using the cmuscheme48
+command package.  This is in the Scheme 48 distribution's emacs/
+subdirectory.  It is a variant of the "cmuscheme" library, which
+comes to us courtesy of Olin Shivers, formerly of CMU.  You might want
+to put the following in your emacs init file (.emacs):
+
+    (setq scheme-program-name "scheme48")
+    (autoload 'run-scheme  "cmuscheme48" "Run an inferior Scheme process." t)
+
+To make the autoload and (require ...) forms work, you will also need
+to put the directory containing cmuscheme and related files in your
+emacs load-path:
+
+    (setq load-path (append load-path '("<scheme-48-directory>/emacs")))
+
+For further documentation see emacs/cmuscheme48.el and emacs/comint.el.
+
+-----
+
+Performance
+
+If you want to generally have your code run faster than it normally
+would, enter "benchmark mode" before loading anything.  Otherwise
+calls to primitives (like + and cons) and in-line procedures (like not
+and cadr) won't be open-coded, and programs will run more slowly.
+Enter benchmark mode by issuing the ,bench command to the command
+processor.
+
+The system doesn't start in benchmark mode by default because the
+Scheme report permits redefinitions of built-in procedures.  In
+benchmark mode, such redefinitions don't work according to the report,
+because previously compiled calls may have in-lined the old
+definition, leaving no opportunity to call the new definition.
+
+",bench" toggles benchmark mode.  ",bench on" and ",bench off" turn it
+on and off.
+
+-----
+
+Inspector
+
+There is a low-tech inspector available via the ,inspect and ,debug
+commands.  The ,inspect command starts an inspector command loop.
+There is a focus object (the same as the command processor's ##), for
+which a menu of selectable components is displayed.  To inspect a
+particular component, just type the corresponding number in the menu.
+For example:
+
+	,inspect '(a (b c) d)
+	(a (b c) d)
+
+	[0] a
+	[1] (b c)
+	[2] d
+	inspect: 1
+	(b c)
+
+	[0] b
+	[1] c
+	inspect: 
+
+When a new object is selected, the previous one is pushed onto a
+stack.  You can pop the stack, reverting to the previous object, with
+the U command.
+
+The inspector is particularly useful with procedures, continuations,
+and records.
+
+Other inspector commands:
+	u	pop object stack
+	d	down stack (current object must be a continuation)
+	m	print more of a long menu
+	(...)   evaluate a form and select result
+	t	select a closure or continuation's template
+	q       quit
+
+## is always the object currently being inspected.  After a Q command,
+or an error in the inspector, ## is the last object that was being
+inspected.
+
+The inspector also accepts arbitrary command processor commands, e.g.
+the ,dis command (see below).  The leading comma is optional.
+
+After an error occurs, ,debug invokes the inspector on the
+continuation at the point of the error.  The U and D (up and down)
+commands then make the inspector look like a conventional stack
+debugger, with continuations playing the role of stack frames.  D goes
+to older or deeper continuations (frames), and U goes back up to more
+recent ones.
+
+Templates are the static components of procedures; these are found
+inside of procedures and continuations, and contain the quoted
+constants and top-level variables referred to by byte-compiled code.
+
+-----
+
+Disassembler
+
+The ,dis command disassembles procedures.
+
+	> ,dis cons
+	cons
+	  0 (check-nargs= 2)
+	  2 (pop)
+	  3 (make-stored-object 2 pair)
+	  6 (return)
+	> 
+
+The command argument is optional; if unsupplied it defaults to the
+current focus object (##).
+
+The disassembler can also be invoked on continuations and templates.
+
+-----
+
+Module system
+
+For information on the module (package) system, see doc/module.tex.
+
+-----
+
+Library
+
+A number of useful utilities are either built in to Scheme 48 or can
+be loaded from an external library.  These utilities are not visible
+in the user environment by default, but can be made available with the
+,open command.  For example, to use the tables structure, do
+
+    > ,open tables
+    > 
+
+If the utility is not already loaded, then the ,open command will
+offer to load it:
+
+    > ,open queues
+    Load structure queues (y/n)? 
+
+Or, you can load something explicitly (without opening it) using the
+load-package command:
+
+    > ,load-package queues
+    ...
+    > ,open queues
+
+When loading a utility, the message "Note: optional optimizer not
+invoked" is innocuous.  Feel free to ignore it.
+
+See also the package system documentation, doc/module.tex.
+
+Unfortunately, few of these wonderful things are documented.  They are
+listed, however, in files rts-packages.scm, comp-packages.scm, and
+more-packages.scm in the distribution directory, and the bindings they
+export are listed in interfaces.scm and more-interfaces.scm.  Here is
+a little information on the more generally useful structures.
+
+architecture
+    Information about the virtual machine.  E.g.
+      (enum op eq?) => the integer opcode of the EQ? instruction
+
+arrays
+    Arrays.  See comments at the top of file big/array.scm.
+
+ascii
+    CHAR->ASCII and ASCII->CHAR.  Similar to CHAR->INTEGER and
+    INTEGER->CHAR except that ASCII encoding is guaranteed.
+
+big-scheme
+    Many generally useful features.  See doc/big-scheme.txt.
+
+bigbit
+    Extensions to the bitwise logical operators (exported by
+    the BITWISE structure) so that they operate on bignums.
+    To use these you should do
+
+        ,load-package bigbit
+	,open bitwise
+
+bitwise
+    Bitwise logical operators.  See doc/big-scheme.txt.
+
+conditions
+    Part of the condition system: DEFINE-CONDITION-PREDICATE and
+    routines for examining condition objects.  (See also handle,
+    signals.)
+
+define-record-types
+    A DEFINE-RECORD-TYPE macro, providing a concise front end to the
+    record package.  (Richard and Jonathan favor different
+    record type defining macros; this one is Jonathan's.)
+
+    The general syntax is:
+      (define-record-type <tag> <type-name>
+        (<constructor-name> <field-tag>*)
+	<predicate-name>
+	(<field-tag> <accessor-name> [<modifier-name>])*)
+
+    Example:
+      (define-record-type pare :pare
+        (kons x y)
+	pare?
+	(x kar set-kar!)
+	(y kdr))
+    This defines KONS to be a constructor, KAR and KDR to be
+    accessors, SET-KAR! to be a modifier, and PARE? to be a predicate
+    for a new type of object.  The type itself is named :PARE.
+    PARE is a tag used in printing the new objects.
+    The field tags X and Y are used in the inspector and to match
+    constructor arguments with fields.
+
+    By default, the new objects print as #{Pare}.  The print method
+    can be modified using DEFINE-RECORD-DISCLOSER:
+      (define-record-discloser :pare
+        (lambda (p) `(pare ,(kar p) ,(kdr p))))
+
+defpackage
+    The module system: DEFINE-STRUCTURE and DEFINE-INTERFACE.
+
+defrecord
+    A define-record-type macro, providing more concise use of the
+    record package.  (Richard and Jonathan favor different
+    record type defining macros; this one is Richard's.)
+
+destructuring
+    DESTRUCTURE macro.  See doc/big-scheme.txt.
+
+display-conditions
+    Displaying condition objects.
+        (DISPLAY-CONDITION condition port) => unspecific
+	  Display condition in an easily readable form.  E.g.
+	  > ,open display-conditions handle conditions
+	  > (display-condition
+	     (call-with-current-continuation
+	       (lambda (k)
+		 (with-handler (lambda (c punt)
+				 (if (error? c)
+				     (k c)
+				     (punt)))
+		   (lambda () (+ 1 'a)))))
+	     (current-output-port))
+
+	  Error: exception
+		 (+ 1 'a)
+	  > 
+
+enumerated
+    Enumerated types.  See doc/big-scheme.txt.
+
+extended-ports
+    Ports for reading from and writing to strings, and related things.
+    See doc/big-scheme.txt.
+
+externals
+    Rudimentary external function interface.  See doc/external.txt.
+
+filenames
+    Rudimentary file name parsing and synthesis.  E.g.
+    file-name-directory and file-name-nondirectory are as in Gnu emacs.
+
+floatnums
+    Floating point numbers.  These are in a very crude state; use at
+    your own risk.  They are slow and do not read or print correctly.
+
+fluids
+    Dynamically bound "variables."
+      (MAKE-FLUID top-level-value) => a "fluid" object
+      (FLUID fluid) => current value of fluid object
+      (SET-FLUID! fluid value) => unspecific; changes current value of
+        fluid object
+      (LET-FLUID fluid value thunk) => whatever thunk returns
+        Within the dynamic extent of execution of (thunk), the fluid
+        object has value as its binding (unless changed by SET-FLUID!
+        or overridden by another LET-FLUID).
+    E.g.
+      (define f (make-fluid 7))
+      (define (baz) (+ (fluid f) 1))
+      (baz)   ;=> 8
+      (let-fluid f 4 (lambda () (+ (baz) 1)))  ;=> 6
+
+formats
+    A simple FORMAT procedure, similar to Common Lisp's or T's.
+    See doc/big-scheme.txt for documentation.
+
+general-tables
+    An extended version of TABLES; supports tables keyed by strings.
+    See doc/big-scheme.txt.
+
+handle
+    Part of the condition system.
+      (WITH-HANDLER handler thunk) => whatever thunk returns.
+        handler is a procedure of two arguments.  The first argument
+	is a condition object, and the second is a "punt" procedure.
+	The handler should examine the condition object (using ERROR?,
+	etc. from the CONDITIONS structure).  If it decides not to do
+	anything special, it should tail-call the "punt" procedure.
+	Otherwise it should take appropriate action and perform a
+	non-local exit.  It should not just return unless it knows
+	damn well what it's doing; returns in certain situations can
+	cause VM crashes.
+
+interrupts
+    Interrupt system
+
+ports
+    A few extra port-related operations, notably FORCE-OUTPUT.
+
+pp
+    A pretty-printer.  (p <exp>) will pretty-print the result of <exp>,
+    which must be an S-expression.  (Source code for procedures is not
+    retained or reconstructed.)  You can also do (p <exp> <port>) to
+    print to a specific port.
+
+    The procedure pretty-print takes three arguments: the object to be
+    printed, a port to write to, and the current horizontal cursor
+    position.  If you've just done a newline, then pass in zero for
+    the position argument.
+
+    The algorithm is very peculiar, and sometimes buggy.
+
+queues
+    FIFO queues.
+
+random
+    Not-very-random random number generator.  The <seed> should be between
+    0 and 2^28 exclusive.
+
+        > (define random (make-random <seed>))
+	> (random)  =>  a pseudo-random number between 0 and 2^28
+
+receiving
+    Convenient interface to the call-with-values procedure, like
+    Common Lisp's multiple-value-bind macro.  See doc/big-scheme.txt.
+
+records
+    MAKE-RECORD-TYPE and friends.  See the Scheme of Things column in
+    Lisp Pointers, volume 4, number 1, for documentation.
+
+recnums
+    Complex numbers.  This should be loaded (e.g. with ,load-package)
+    but needn't be opened.
+
+search-trees
+    Balanced binary search trees.  See comments at top of
+    big/search-tree.scm. 
+
+signals
+    ERROR, WARN, and related procedures.
+
+sort
+    Online merge sort (see comment at top of file big/sort.scm).
+
+        (sort-list <list> <pred>)
+	(sort-list! <list> <pred>)
+
+sicp
+    Compatibility package for the Scheme dialect used in the book
+    "Structure and Interpretation of Computer Programs."
+
+sockets
+    Interface to Unix BSD sockets.  See comments at top of file
+    misc/socket.scm.
+
+tables
+    Hashed association tables.  Keys are compared using EQ?.
+    See doc/big-scheme.txt.
+
+threads
+    Multitasking.  See doc/threads.txt.
+
+util
+    SUBLIST, ANY, REDUCE, FILTER, and some other useful things.
+
+weak
+    Weak pointers and populations.
+        (MAKE-WEAK-POINTER thing) => weak-pointer
+	(WEAK-POINTER-REF weak-pointer) => thing or #F
+	  #F if the thing has been gc'ed.
+
+writing
+        (RECURRING-WRITE thing port recur) => unspecific
+	  This is the same as WRITE except that recursive calls invoke
+	  the recur argument instead of WRITE.  For an example, see
+	  the definition of LIMITED-WRITE in env/dispcond.scm, which
+	  implements processing similar to common Lisp's *print-level*
+	  and *print-length*.
+
+-----
+
+Acknowledgment
+
+Thanks to Deborah Tatar for providing the Yeats quotation.
diff --git a/doc/utilities.ps b/doc/utilities.ps
new file mode 100644
index 0000000..ea021ab
--- /dev/null
+++ b/doc/utilities.ps
@@ -0,0 +1,2536 @@
+%!PS-Adobe-2.0
+%%Creator: dvipsk 5.58f Copyright 1986, 1994 Radical Eye Software
+%%Title: utilities.dvi
+%%Pages: 7
+%%PageOrder: Ascend
+%%BoundingBox: 0 0 612 792
+%%DocumentPaperSizes: Letter
+%%EndComments
+%DVIPSCommandLine: /usr/bin/dvips -D 600 -f utilities.dvi
+%DVIPSParameters: dpi=600, comments removed
+%DVIPSSource:  TeX output 1999.02.23:1820
+%%BeginProcSet: tex.pro
+/TeXDict 250 dict def TeXDict begin /N{def}def /B{bind def}N /S{exch}N
+/X{S N}B /TR{translate}N /isls false N /vsize 11 72 mul N /hsize 8.5 72
+mul N /landplus90{false}def /@rigin{isls{[0 landplus90{1 -1}{-1 1}
+ifelse 0 0 0]concat}if 72 Resolution div 72 VResolution div neg scale
+isls{landplus90{VResolution 72 div vsize mul 0 exch}{Resolution -72 div
+hsize mul 0}ifelse TR}if Resolution VResolution vsize -72 div 1 add mul
+TR[matrix currentmatrix{dup dup round sub abs 0.00001 lt{round}if}
+forall round exch round exch]setmatrix}N /@landscape{/isls true N}B
+/@manualfeed{statusdict /manualfeed true put}B /@copies{/#copies X}B
+/FMat[1 0 0 -1 0 0]N /FBB[0 0 0 0]N /nn 0 N /IE 0 N /ctr 0 N /df-tail{
+/nn 8 dict N nn begin /FontType 3 N /FontMatrix fntrx N /FontBBox FBB N
+string /base X array /BitMaps X /BuildChar{CharBuilder}N /Encoding IE N
+end dup{/foo setfont}2 array copy cvx N load 0 nn put /ctr 0 N[}B /df{
+/sf 1 N /fntrx FMat N df-tail}B /dfs{div /sf X /fntrx[sf 0 0 sf neg 0 0]
+N df-tail}B /E{pop nn dup definefont setfont}B /ch-width{ch-data dup
+length 5 sub get}B /ch-height{ch-data dup length 4 sub get}B /ch-xoff{
+128 ch-data dup length 3 sub get sub}B /ch-yoff{ch-data dup length 2 sub
+get 127 sub}B /ch-dx{ch-data dup length 1 sub get}B /ch-image{ch-data
+dup type /stringtype ne{ctr get /ctr ctr 1 add N}if}B /id 0 N /rw 0 N
+/rc 0 N /gp 0 N /cp 0 N /G 0 N /sf 0 N /CharBuilder{save 3 1 roll S dup
+/base get 2 index get S /BitMaps get S get /ch-data X pop /ctr 0 N ch-dx
+0 ch-xoff ch-yoff ch-height sub ch-xoff ch-width add ch-yoff
+setcachedevice ch-width ch-height true[1 0 0 -1 -.1 ch-xoff sub ch-yoff
+.1 sub]{ch-image}imagemask restore}B /D{/cc X dup type /stringtype ne{]}
+if nn /base get cc ctr put nn /BitMaps get S ctr S sf 1 ne{dup dup
+length 1 sub dup 2 index S get sf div put}if put /ctr ctr 1 add N}B /I{
+cc 1 add D}B /bop{userdict /bop-hook known{bop-hook}if /SI save N @rigin
+0 0 moveto /V matrix currentmatrix dup 1 get dup mul exch 0 get dup mul
+add .99 lt{/QV}{/RV}ifelse load def pop pop}N /eop{SI restore userdict
+/eop-hook known{eop-hook}if showpage}N /@start{userdict /start-hook
+known{start-hook}if pop /VResolution X /Resolution X 1000 div /DVImag X
+/IE 256 array N 0 1 255{IE S 1 string dup 0 3 index put cvn put}for
+65781.76 div /vsize X 65781.76 div /hsize X}N /p{show}N /RMat[1 0 0 -1 0
+0]N /BDot 260 string N /rulex 0 N /ruley 0 N /v{/ruley X /rulex X V}B /V
+{}B /RV statusdict begin /product where{pop product dup length 7 ge{0 7
+getinterval dup(Display)eq exch 0 4 getinterval(NeXT)eq or}{pop false}
+ifelse}{false}ifelse end{{gsave TR -.1 .1 TR 1 1 scale rulex ruley false
+RMat{BDot}imagemask grestore}}{{gsave TR -.1 .1 TR rulex ruley scale 1 1
+false RMat{BDot}imagemask grestore}}ifelse B /QV{gsave newpath transform
+round exch round exch itransform moveto rulex 0 rlineto 0 ruley neg
+rlineto rulex neg 0 rlineto fill grestore}B /a{moveto}B /delta 0 N /tail
+{dup /delta X 0 rmoveto}B /M{S p delta add tail}B /b{S p tail}B /c{-4 M}
+B /d{-3 M}B /e{-2 M}B /f{-1 M}B /g{0 M}B /h{1 M}B /i{2 M}B /j{3 M}B /k{
+4 M}B /w{0 rmoveto}B /l{p -4 w}B /m{p -3 w}B /n{p -2 w}B /o{p -1 w}B /q{
+p 1 w}B /r{p 2 w}B /s{p 3 w}B /t{p 4 w}B /x{0 S rmoveto}B /y{3 2 roll p
+a}B /bos{/SS save N}B /eos{SS restore}B end
+%%EndProcSet
+TeXDict begin 40258431 52099146 1000 600 600 (utilities.dvi)
+@start /Fa 2 103 df<00000F003C0000001F807E0000001F807E0000001F807E000000
+3F80FE0000003F00FC0000003F00FC0000007F01FC0000007E01F80000007E01F8000000
+FE03F8000000FC03F0000000FC03F0000001FC07F00003FFFFFFFE0007FFFFFFFF000FFF
+FFFFFF800FFFFFFFFF8007FFFFFFFF0003FFFFFFFE00000FC03F0000000FC03F0000001F
+C07F0000001F807E0000001F807E0000003F80FE0000003F00FC0000003F00FC0000007F
+01FC0000007E01F8000000FE03F8000000FC03F000007FFFFFFFC000FFFFFFFFF000FFFF
+FFFFF000FFFFFFFFF000FFFFFFFFF0007FFFFFFFE00007E01F8000000FE03F8000000FC0
+3F0000000FC03F0000001FC07F0000001F807E0000001F807E0000003F80FE0000003F00
+FC0000003F00FC0000003F00FC0000003E00F80000001C0070000000293379B22C>35
+D<00000003FC000000001FFF000000003FFFC00000007FFFC00000007FFFE0000000FE1F
+E0000000FC1FE0000000FC1FE0000000FC1FE0000001FC0FC0000001F80780000001F800
+00000001F80000000001F80000000001F800000003FFFFF8000003FFFFFC000007FFFFFC
+000003FFFFFC000003FFFFF800000007F00000000007E00000000007E00000000007E000
+00000007E00000000007E0000000000FE0000000000FC0000000000FC0000000000FC000
+0000000FC0000000000FC0000000001FC0000000001F80000000001F80000000001F8000
+0000001F80000000001F80000000003F80000000003F00000000003F00000000003F0000
+0000003F00000000007F00000000007E00000000007E00000000007E00000000007E0000
+0000007E0000000000FE0000000000FC0000000000FC0000000000FC0000000001FC0000
+000001F80000000001F80000000001F80000000003F80000001C03F00000007F03F00000
+007F07F0000000FF07E0000000FF0FE0000000FF1FC0000000FFFF800000007FFF800000
+003FFF000000001FFC0000000007F0000000002B457DB22C>102
+D E /Fb 1 49 df<003F800001FFF00003E0F80007803C000F001E001E000F003E000F80
+3E000F803C0007807C0007C07C0007C07C0007C07C0007C0FC0007E0FC0007E0FC0007E0
+FC0007E0FC0007E0FC0007E0FC0007E0FC0007E0FC0007E0FC0007E0FC0007E0FC0007E0
+FC0007E0FC0007E07C0007C07C0007C07C0007C03E000F803E000F803E000F801F001F00
+0F001E0007803C0003E0F80001FFF000003F80001B277EA521>48
+D E /Fc 31 122 df<000000003FFC0000000001FFFF8000000007E007C00000001F8001
+E00000003F0001F00000007E0003F0000000FC0007F0000000FC0007F0000001F80007F0
+000001F80007E0000003F0000380000003F0000000000003F0000000000003F000000000
+0007F0000000000007E0000000000007E0000000000007E0000000000007E00000000000
+0FE000000000000FC000000000000FC000000000000FC0000000000FFFFFFFFF00000FFF
+FFFFFF00000FFFFFFFFE0000001F80007E0000001F80007E0000001F8000FE0000003F80
+00FC0000003F0000FC0000003F0000FC0000003F0001FC0000003F0001F80000007F0001
+F80000007E0001F80000007E0003F80000007E0003F00000007E0003F0000000FE0003F0
+000000FC0007F0000000FC0007E0000000FC0007E0000000FC0007E0000001FC000FE000
+0001FC000FC0000001F8000FC1C00001F8000FC1C00001F8001FC1C00001F8001F83C000
+03F8001F83800003F0001F83800003F0001F83800003F0001F87000007F0001F87000007
+E0001F0F000007E0000F8E000007E000079E000007E00003FC00000FE00000F000000FC0
+00000000000FC000000000000FC000000000000F8000000000001F8000000000001F8000
+0000001C1F00000000007E1F00000000007E3F0000000000FE3E0000000000FE3C000000
+0000FE7C0000000000F878000000000078F000000000003FE000000000000F8000000000
+00344C82BA2F>12 D<7FFFF87FFFF8FFFFF8FFFFF8FFFFF0150579941E>45
+D<0E003F807F80FF80FF80FF80FF007E003C000909778819>I<00000003FE000E000000
+3FFF801E000000FFFFE03C000003FE01F03C00000FF000787C00003FC0003CFC00007F00
+001FF80000FE00000FF80003FC00000FF80007F8000007F8000FF0000007F0001FE00000
+03F0003FC0000003F0003F80000003F0007F00000003E000FF00000003E001FE00000003
+E001FC00000003E003FC00000003C007F800000003C007F800000003C00FF000000003C0
+0FF000000003801FE000000003801FE000000000001FE000000000003FC000000000003F
+C000000000003FC000000000007FC000000000007F8000000000007F8000000000007F80
+0000000000FF800000000000FF000000000000FF000000000000FF000000000000FF0000
+00000000FF000000003800FF000000003800FF000000007800FE000000007000FF000000
+007000FF00000000F0007F00000000E0007F00000001E0007F00000001C0007F00000003
+C0003F8000000780003F8000000700001F8000000E00001FC000001E00000FC000003C00
+000FE0000078000007F00001F0000003F80003C0000001FE000F800000007F807E000000
+003FFFFC000000000FFFE00000000000FF00000000373D74BA3B>67
+D<0003FFFFFFFE00000003FFFFFFFFC0000003FFFFFFFFF000000007F8000FF800000007
+F00003FC00000007F00000FE0000000FF000007F0000000FF000003F8000000FE000001F
+8000000FE000001FC000001FE000000FC000001FE000000FE000001FC000000FE000001F
+C0000007E000003FC0000007E000003FC0000007F000003F80000007F000003F80000007
+F000007F80000007F000007F80000007F000007F00000007F000007F00000007F00000FF
+00000007F00000FF0000000FF00000FE0000000FF00000FE0000000FF00001FE0000000F
+F00001FE0000000FE00001FC0000001FE00001FC0000001FE00003FC0000001FE00003FC
+0000001FC00003F80000003FC00003F80000003FC00007F80000003F800007F80000007F
+800007F00000007F000007F00000007F00000FF0000000FE00000FF0000000FE00000FE0
+000001FC00000FE0000001F800001FE0000003F800001FE0000007F000001FC0000007E0
+00001FC000000FC000003FC000001F8000003FC000003F8000003F8000007F0000003F80
+0000FC0000007F800003F80000007F800007F00000007F00001FC0000000FF0001FF8000
+007FFFFFFFFE000000FFFFFFFFF0000000FFFFFFFF800000003C397CB83F>I<0003FFFF
+F80FFFFFE00003FFFFF80FFFFFE00003FFFFF80FFFFFE0000007F800001FE000000007F0
+00001FC000000007F000001FC00000000FF000003FC00000000FF000003F800000000FE0
+00003F800000000FE000003F800000001FE000007F800000001FE000007F000000001FC0
+00007F000000001FC000007F000000003FC00000FF000000003FC00000FE000000003F80
+0000FE000000003F800000FE000000007F800001FE000000007F800001FC000000007F00
+0001FC000000007F000001FC00000000FF000003FC00000000FF000003F800000000FE00
+0003F800000000FE000003F800000001FFFFFFFFF800000001FFFFFFFFF000000001FFFF
+FFFFF000000001FC000007F000000003FC00000FF000000003FC00000FE000000003F800
+000FE000000003F800000FE000000007F800001FE000000007F800001FC000000007F000
+001FC000000007F000001FC00000000FF000003FC00000000FF000003F800000000FE000
+003F800000000FE000003F800000001FE000007F800000001FE000007F000000001FC000
+007F000000001FC000007F000000003FC00000FF000000003FC00000FE000000003F8000
+00FE000000003F800000FE000000007F800001FE000000007F800001FC000000007F0000
+01FC00000000FF000003FC0000007FFFFE01FFFFF80000FFFFFE03FFFFF80000FFFFFE03
+FFFFF8000043397CB83E>72 D<0007FFFFFC000007FFFFFC000007FFFFF80000000FF800
+0000000FF0000000000FE0000000001FE0000000001FE0000000001FC0000000001FC000
+0000003FC0000000003FC0000000003F80000000003F80000000007F80000000007F8000
+0000007F00000000007F0000000000FF0000000000FF0000000000FE0000000000FE0000
+000001FE0000000001FE0000000001FC0000000001FC0000000003FC0000000003FC0000
+000003F80000000003F80000000007F80000000007F80000000007F00000000007F00000
+00000FF0000000000FF000000C000FE000001C000FE000001C001FE000003C001FE00000
+38001FC0000078001FC0000078003FC0000070003FC00000F0003F800000E0003F800001
+E0007F800003E0007F800003C0007F000007C0007F00000FC000FF00001F8000FF00003F
+8000FE0000FF8001FE0007FF00FFFFFFFFFF00FFFFFFFFFF00FFFFFFFFFE002E397BB834
+>76 D<0007FFFFFFF8000007FFFFFFFF000007FFFFFFFF8000000FF0003FE000000FE000
+0FF000000FE00003F800001FE00003F800001FE00001FC00001FC00001FC00001FC00001
+FC00003FC00001FE00003FC00001FE00003F800001FE00003F800001FE00007F800001FE
+00007F800003FC00007F000003FC00007F000003FC0000FF000003F80000FF000007F800
+00FE000007F00000FE00000FE00001FE00000FE00001FE00001FC00001FC00003F800001
+FC0000FE000003FC0001FC000003FC000FF0000003FFFFFFC0000003FFFFFE00000007F8
+000000000007F8000000000007F0000000000007F000000000000FF000000000000FF000
+000000000FE000000000000FE000000000001FE000000000001FE000000000001FC00000
+0000001FC000000000003FC000000000003FC000000000003F8000000000003F80000000
+00007F8000000000007F8000000000007F0000000000007F000000000000FF0000000000
+00FF000000000000FE000000000001FE0000000000FFFFFC00000000FFFFFC00000000FF
+FFFC0000000037397BB838>80 D<07FFFFFFFFFFE007FFFFFFFFFFE00FFFFFFFFFFFE00F
+F800FF001FE00FC000FE0007C01F8000FE0007C01F0001FE0003C01E0001FE0003C01C00
+01FC0003C03C0001FC0003803C0003FC000380380003FC000380780003F8000380700003
+F8000780700007F8000780F00007F8000700E00007F0000700E00007F0000700E0000FF0
+00070000000FF000000000000FE000000000000FE000000000001FE000000000001FE000
+000000001FC000000000001FC000000000003FC000000000003FC000000000003F800000
+0000003F8000000000007F8000000000007F8000000000007F0000000000007F00000000
+0000FF000000000000FF000000000000FE000000000000FE000000000001FE0000000000
+01FE000000000001FC000000000001FC000000000003FC000000000003FC000000000003
+F8000000000003F8000000000007F8000000000007F8000000000007F0000000000007F0
+00000000000FF000000000000FF000000000000FE000000000003FF0000000007FFFFFF8
+000000FFFFFFF8000000FFFFFFF8000000333971B83B>84 D<0000F800000007FE000000
+1F871C00003E03FE00007C03FE0000F801FE0001F801FE0003F000FC0007E000FC000FE0
+00FC000FC001FC001FC001F8001FC001F8003F8001F8003F8003F8007F8003F0007F0003
+F0007F0003F0007F0007F000FF0007E000FE0007E000FE0007E000FE000FE000FE000FC0
+00FC000FC1C0FC000FC1C0FC001FC1C0FC001F83C0FC001F8380FC003F8380FC003F8780
+7C007F87007C00FF07003E01FF0F003E038F8E001F0F079E0007FE03FC0001F000F00022
+2677A42A>97 D<003F00001FFF00001FFF00001FFF0000007F0000007E0000007E000000
+7E000000FE000000FC000000FC000000FC000001FC000001F8000001F8000001F8000003
+F8000003F0000003F0000003F0000007F0000007E0F80007E7FE0007EF0F800FFC07C00F
+F807C00FF003E00FE003E01FC003F01FC003F01F8003F01F8003F03F8003F03F0003F03F
+0003F03F0007F07F0007F07E0007F07E0007F07E000FF0FE000FF0FC000FE0FC000FE0FC
+001FE0FC001FC0F8001FC0F8003F80F8003F80F8003F00F8007F00F8007E00F800FC0078
+01F8007C01F0003C03E0003E07C0001E1F80000FFE000001F000001C3B77B926>I<0000
+7F000003FFC0000FC1E0001F0070007E007800FC003801F801F803F003F807F003F807E0
+03F80FE003F81FC003F01FC000003F8000003F8000007F8000007F0000007F0000007F00
+0000FF000000FE000000FE000000FE000000FE000000FC000000FC000000FC000000FC00
+0030FC000038FC0000787C0000F07E0001E03E0003C03E000F801F003E000F81F80003FF
+E00000FF00001D2677A426>I<00000001F8000000FFF8000000FFF8000000FFF8000000
+03F800000003F000000003F000000007F000000007F000000007E000000007E00000000F
+E00000000FE00000000FC00000000FC00000001FC00000001FC00000001F800000001F80
+0000003F800000003F800000F83F000007FE3F00001F877F00003E03FF00007C03FE0000
+F801FE0001F801FE0003F000FE0007E000FC000FE000FC000FC001FC001FC001FC001FC0
+01F8003F8001F8003F8003F8007F8003F8007F0003F0007F0003F0007F0007F000FF0007
+F000FE0007E000FE0007E000FE000FE000FE000FE000FC000FC1C0FC000FC1C0FC001FC1
+C0FC001FC3C0FC001F8380FC003F8380FC003F87807C007F87007C00FF07003E01FF0F00
+3E038F8E001F0F079E0007FE03FC0001F000F000253B77B92A>I<00007F000003FFC000
+0FC1E0003F00F0007E007800FC007801F8007803F0007807E000780FE000780FC000F81F
+C000F03F8001F03F8007E03F801F807F81FF007FFFF8007FFF00007F000000FF000000FE
+000000FE000000FE000000FE000000FE000000FC000000FC000000FC0000307C0000387C
+0000787E0000F03E0001E03E0003C01F000F800F003E000781F80003FFE00000FF00001D
+2677A426>I<00000007C00000001FF00000003E380000007C3C000000F8FC000000F9FC
+000001F9FC000001F1FC000003F1F8000003F0F0000003F000000007F000000007E00000
+0007E000000007E000000007E00000000FE00000000FC00000000FC00000000FC0000000
+0FC00000001FC00000001F8000000FFFFFC0001FFFFFC0001FFFFF8000003F800000003F
+000000003F000000003F000000003F000000007F000000007E000000007E000000007E00
+0000007E00000000FE00000000FC00000000FC00000000FC00000000FC00000001FC0000
+0001F800000001F800000001F800000001F800000003F800000003F000000003F0000000
+03F000000003F000000007F000000007E000000007E000000007E000000007E00000000F
+E00000000FC00000000FC00000000FC00000001FC00000001F800000001F800000001F80
+0000001F000000003F0000001C3F0000007E3E0000007E3E000000FE3C000000FE7C0000
+00FE78000000F8F000000078F00000003FC00000000F80000000264C82BA19>I<000007
+C00000003FF0000000FC38E00001F01FF00003E01FF00007C00FF0000F800FF0001F8007
+F0003F0007E0007F0007E0007E000FE000FE000FE000FC000FC001FC000FC001FC001FC0
+03FC001FC003F8001F8003F8001F8003F8003F8007F8003F8007F0003F0007F0003F0007
+F0007F0007F0007F0007E0007E0007E0007E0007E000FE0007E000FE0007E000FC0003E0
+01FC0003E003FC0003E007FC0001F00FF80000F01FF80000787BF800003FF3F800000FC3
+F000000003F000000007F000000007F000000007E000000007E00000000FE00000000FC0
+001C000FC0007E001FC0007E001F8000FE003F0000FE007E0000FE00FC00007801F80000
+7C07E000001FFF80000003FE00000024367CA426>I<0003F0000001FFF0000001FFF000
+0001FFF000000007F000000007E000000007E000000007E00000000FE00000000FC00000
+000FC00000000FC00000001FC00000001F800000001F800000001F800000003F80000000
+3F000000003F000000003F000000007F000000007E07F000007E1FFC00007E783E0000FF
+E01F0000FFC01F8000FF800F8000FF000F8001FE000F8001FE000FC001FC000FC001F800
+1F8003F8001F8003F0001F8003F0001F8003F0003F8007F0003F0007E0003F0007E0003F
+0007E0007F000FE0007E000FC0007E000FC000FE000FC000FC001FC000FC001F8001FC1C
+1F8001F81C1F8001F83C3F8003F8383F0003F0383F0003F0383F0003F0707F0003E0707E
+0003E0F07E0003E0E07E0003E1C0FE0001E380FC0000FF003800003C00263B7BB92A>I<
+0001C00007E00007F0000FF0000FE00007E0000380000000000000000000000000000000
+00000000000000000000000000000000000000F00003FC00071E000E1F001C1F001C1F00
+381F00383F00703F00703F00707F00F07E00E07E00E0FE0000FC0000FC0001FC0001F800
+03F80003F80003F00007F00007E00007E0000FE0E00FC0E00FC1E01FC1C01F81C01F81C0
+1F83801F03801F07001F07001F0E000F1C0007F80001E000143879B619>I<0003F00000
+01FFF0000001FFF0000001FFF000000007F000000007E000000007E000000007E0000000
+0FE00000000FC00000000FC00000000FC00000001FC00000001F800000001F800000001F
+800000003F800000003F000000003F000000003F000000007F000000007E000F80007E00
+3FE0007E00F0E000FE01C1F000FC0387F000FC0707F000FC0E07F001FC1C07E001F83807
+E001F830038001F870000003F8E0000003F1C0000003F380000003FF00000007FC000000
+07FE00000007FFC0000007E7F800000FE1FC00000FC07E00000FC07F00000FC03F00001F
+C03F80001F801F81C01F801F81C01F801F83C03F803F83803F003F03803F003F03803F00
+3F07807F003F07007E003E07007E001E0E007E001E1E00FE000F3C00FC0007F800380001
+E000243B7BB926>107 D<000FC007FFC007FFC007FFC0001FC0001F80001F80003F8000
+3F80003F00003F00007F00007F00007E00007E0000FE0000FE0000FC0000FC0001FC0001
+FC0001F80001F80003F80003F80003F00003F00007F00007F00007E00007E0000FE0000F
+E0000FC0000FC0001FC0001FC0001F80001F80003F80003F80003F00003F00007F00007F
+00007E0E007E0E00FE0E00FE1E00FC1C00FC1C00FC3C00FC3800F83800F878007870007C
+E0001FE0000F8000123B79B915>I<01E000FE0007F00007F803FF801FFC000E3C0F07C0
+783E001E3E3C03E1E01F001C1F7803F3C01F80383FF001F7800F80383FE001F7000F8078
+3FC001FE000F80703FC001FE000FC0703F8001FC000FC0703F0003F8001F80F07F0003F8
+001F80E07E0003F0001F80E07E0003F0001F80007E0007F0003F8000FE0007F0003F0000
+FC0007E0003F0000FC0007E0003F0000FC000FE0007F0001FC000FE0007E0001F8000FC0
+007E0001F8000FC000FE0001F8001FC000FC0003F8001FC000FC0003F0001F8001FC1C03
+F0001F8001F81C03F0003F8001F83C07F0003F8003F83807E0003F0003F03807E0003F00
+03F03807E0007F0003F0700FE0007F0003E0700FC0007E0003E0F00FC0007E0003E0E00F
+C000FE0003E1C01FC000FE0001E3C01F8000FC0000FF000700003800003C003E2679A444
+>I<01E000FE000007F803FF80000E3C0F07C0001E3E3C03E0001C1F7803F000383FF001
+F000383FE001F000783FC001F000703FC001F800703F8001F800703F0003F000F07F0003
+F000E07E0003F000E07E0003F000007E0007F00000FE0007E00000FC0007E00000FC0007
+E00000FC000FE00001FC000FC00001F8000FC00001F8001FC00001F8001F800003F8001F
+800003F0003F838003F0003F038003F0003F078007F0007F070007E0007E070007E0007E
+070007E0007E0E000FE0007C0E000FC0007C1E000FC0007C1C000FC0007C38001FC0003C
+78001F80001FE000070000078000292679A42F>I<00007F000003FFC0000FC1F0001F00
+F8007E007C00FC007C01F8007E03F0003E07F0003F07E0003F0FE0003F1FC0003F1FC000
+3F3F80003F3F80007F7F80007F7F00007F7F00007F7F0000FFFF0000FFFE0000FEFE0000
+FEFE0001FEFE0001FCFC0001FCFC0003F8FC0003F8FC0007F0FC0007E0FC000FE07C000F
+C07E001F803E003F003E007E001F00F8000F83F00003FFC00000FE0000202677A42A>I<
+00078007C000001FE03FF000003CF0787C000038F8E03E0000787FC03E0000707F801F00
+0070FF001F0000F0FE001F8000E0FE001F8000E0FC001F8001E1FC001F8001C1FC001F80
+01C1F8001F8001C1F8001F800003F8003F800003F8003F800003F0003F800003F0003F80
+0007F0007F800007F0007F800007E0007F000007E0007F00000FE000FF00000FE000FE00
+000FC000FE00000FC001FC00001FC001FC00001FC001F800001F8003F800001F8003F000
+003F8007E000003FC00FC000003FC00F8000003FE01F0000007FE03E0000007F70FC0000
+007E3FF00000007E0F80000000FE0000000000FE0000000000FC0000000000FC00000000
+01FC0000000001FC0000000001F80000000001F80000000003F80000000003F800000000
+03F00000000007F000000000FFFFC0000000FFFFC0000000FFFFC0000000293580A42A>
+I<03C003F0000FF01FFC001E783C0F001C7C700F003C3EE03F80383FC03F80387F803F80
+787F803F00707F003F00707F001C00F07E000000E0FE000000E0FC000000E0FC00000000
+FC00000001FC00000001F800000001F800000001F800000003F800000003F000000003F0
+00000003F000000007F000000007E000000007E000000007E00000000FE00000000FC000
+00000FC00000000FC00000001FC00000001F800000001F800000001F800000003F800000
+003F000000000E00000000212679A423>114 D<0000FE000007FF80000F83C0003E00E0
+007C00F00078007000F800F001F803F001F003F001F003F001F003E003F001C003F80000
+03FC000003FFC00001FFF80001FFFE0000FFFF00007FFF80003FFF80000FFFC00000FFC0
+00003FC000001FC000000FC03E000FC07E000FC0FE000F80FE000F80FE000F80FC001F00
+E0001F00F0003E0070007C003800F8001E03E0000FFFC00001FE00001C267AA422>I<00
+03800007C0000FC0000FC0000FC0000FC0001FC0001F80001F80001F80003F80003F0000
+3F00003F00007F00007E007FFFFF7FFFFFFFFFFF00FC0000FC0000FC0001FC0001F80001
+F80001F80003F80003F00003F00003F00007F00007E00007E00007E0000FE0000FC0000F
+C0000FC0001FC0001F801C1F801C1F803C3F80383F00783F00703F00F03F00E03F01C03E
+03C01F07800F0F0007FC0001F000183579B31C>I<00F800000003FE0001C0078F0003E0
+0E0F8007E01E0F8007E01C0F8007E0380F800FE0381F800FE0781F800FC0701F800FC070
+3F801FC0F03F001FC0E03F001F80E07F001F80007E003F80007E003F8000FE003F0000FC
+003F0000FC007F0001FC007F0001F8007E0001F8007E0001F800FE0003F800FE0003F000
+FC0E03F000FC0E03F001FC1E03F001FC1C03F001F81C03E001F81C03E001F83C03F003F8
+3803F007F83801F007F07001F01EF8F000F83C78E0003FF03FC0000FC00F00272679A42D
+>I<00F0000E0003FC003F00071E007F800E1F007F801C1F007F803C1F007F80381F003F
+80383F001F80703F000F80703F000F80707F000F80F07E000F00E07E000700E0FE000700
+00FC000F0000FC000E0001FC000E0001F8000E0001F8001E0003F8001C0003F0001C0003
+F0001C0003F0003C0007F000380007E000380007E000700007E000700007E000700007E0
+00E00007E000E00007E001C00007E003C00003E003800003F007000001F00E000000F83C
+0000007FF80000000FC00000212679A426>I<0007E007C0001FF81FF800787C383C00F0
+3E703C01E01EE0FE03C01FE0FE03801FC0FE07001FC0FC0F001F80FC0E001F80700E003F
+80001E003F00001C003F00001C003F000000007F000000007F000000007E000000007E00
+000000FE00000000FE00000000FC00000000FC00000001FC00000001FC00000001F80070
+0001F800700003F800F00003F800E01C03F000E07E03F001E07E07F001C0FE07F00380FE
+0FF00780FE0EF00F00781CF81E0078387C3C003FF03FF00007C00FC00027267CA427>
+120 D<00F000000003FC0001C0071E0003E00E1F0007E01C1F0007E03C1F0007E0381F00
+0FE0383F000FC0703F000FC0703F000FC0707F001FC0F07E001F80E07E001F80E0FE001F
+8000FC003F8000FC003F0001FC003F0001F8003F0001F8007F0003F8007E0003F0007E00
+03F0007E0003F000FE0007F000FC0007E000FC0007E000FC0007E001FC0007E001F80007
+E001F80007E001F80007E003F80007E003F00007E007F00003E00FF00003F01FF00001F8
+7FE000007FF7E000001FC7E00000000FE00000000FC00000000FC00000001FC0003F001F
+80007F003F80007F003F00007F007E00007F007C00007E00FC00007001F800007003E000
+003807C000003C1F8000000FFE00000003F0000000233679A428>I
+E /Fd 4 104 df<000FE000007FFC0000FFFE0003FFFF8007FFFFC00FFFFFE01FFFFFF0
+3FFFFFF83FFFFFF87FFFFFFC7FFFFFFC7FFFFFFCFFFFFFFEFFFFFFFEFFFFFFFEFFFFFFFE
+FFFFFFFEFFFFFFFEFFFFFFFEFFFFFFFE7FFFFFFC7FFFFFFC7FFFFFFC3FFFFFF83FFFFFF8
+1FFFFFF00FFFFFE007FFFFC003FFFF8000FFFE00007FFC00000FE0001F207BA42A>15
+D<0000000000001E00000000000000001E00000000000000001E00000000000000001E00
+000000000000001F00000000000000000F00000000000000000F00000000000000000F80
+0000000000000007800000000000000007C00000000000000003E00000000000000003E0
+0000000000000001F00000000000000000F80000000000000000FC00000000000000007E
+00000000000000003F00000000000000001F80000000000000000FC00000000000000007
+F07FFFFFFFFFFFFFFFFCFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF7FFFFFFFFFFFFFFF
+FC0000000000000007F0000000000000000FC0000000000000001F80000000000000003F
+00000000000000007E0000000000000000FC0000000000000000F80000000000000001F0
+0000000000000003E00000000000000003E00000000000000007C0000000000000000780
+000000000000000F80000000000000000F00000000000000000F00000000000000001F00
+000000000000001E00000000000000001E00000000000000001E00000000000000001E00
+00482C7BAA53>33 D<000001F800000FF800003F800000FC000001F8000003F0000007E0
+000007E000000FE000000FC000000FC000000FC000000FC000000FC000000FC000000FC0
+00000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC0
+00000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC0
+00001FC000001F8000003F8000007F000000FE000003F800007FE00000FF0000007FE000
+0003F8000000FE0000007F0000003F8000001F8000001FC000000FC000000FC000000FC0
+00000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC0
+00000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC0
+00000FC000000FC000000FC000000FC000000FE0000007E0000007E0000003F0000001F8
+000000FC0000003F8000000FF8000001F81D537ABD2A>102 D<FC000000FFC0000007F0
+000001FC0000007E0000003F0000003F8000001F8000001FC000000FC000000FC000000F
+C000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000F
+C000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000F
+C000000FC000000FC000000FC000000FC000000FE0000007E0000007F0000003F8000001
+FC0000007E0000001FF0000007F800001FF000007E000001FC000003F8000007F0000007
+E000000FE000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000F
+C000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000F
+C000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000001F
+C000001F8000003F8000003F0000007E000001FC000007F00000FFC00000FC0000001D53
+7ABD2A>I E /Fe 56 122 df<1C007F00FF80FF80FF80FF80FF80FF80FF80FF80FF80FF
+80FF80FF80FF80FF80FF80FF80FF807F007F007F007F007F007F007F007F007F007F007F
+007F007F007F007F003E00000000000000000000000000000000001C007F007F00FF80FF
+80FF807F007F001C0009346FB32C>33 D<000F003C00001F807E00001F807E00001F807E
+00001F807E00001F807E00001F807E00001F807E00001F807E00003F80FE00003F00FC00
+003F00FC00003F00FC00003F00FC007FFFFFFFF0FFFFFFFFF8FFFFFFFFF8FFFFFFFFF8FF
+FFFFFFF83FFFFFFFF0007E01F800007E01F800007E01F800007E01F800007E01F80000FE
+03F80000FC03F00000FC03F00000FC03F00000FC03F00000FC03F00000FC03F0003FFFFF
+FFF0FFFFFFFFF8FFFFFFFFF8FFFFFFFFF8FFFFFFFFF87FFFFFFFF001F807E00001F807E0
+0001F807E00003F80FE00003F00FC00003F00FC00003F00FC00003F00FC00003F00FC000
+03F00FC00003F00FC00003F00FC00001E007800025337DB22C>35
+D<0F801FC03FE03FF03FF03FF83FF81FF80FF800F800F800F800F801F801F001F003F003
+E007E00FC01FC03F807F00FE00FC00F80070000D1B71B22C>39 D<0000380000FC0001FC
+0003FC0007F8000FF0001FC0003F80007F0000FE0001FC0003F80003F00007F00007E000
+0FE0000FC0001F80001F80003F80003F00003F00007F00007E00007E00007E0000FE0000
+FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000
+FE00007E00007E00007E00007F00003F00003F00003F80001F80001F80000FC0000FE000
+07E00007F00003F00003F80001FC0000FE00007F00003F80001FC0000FF00007F80003FC
+0001FC0000FC000038164272B92C>I<700000FC0000FE0000FF00007F80003FC0000FE0
+0007F00003F80001FC0000FE00007F00003F00003F80001F80001FC0000FC00007E00007
+E00007F00003F00003F00003F80001F80001F80001F80001FC0000FC0000FC0000FC0000
+FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0001FC0001F80001F80001
+F80003F80003F00003F00007F00007E00007E0000FC0001FC0001F80003F80003F00007F
+0000FE0001FC0003F80007F0000FE0003FC0007F8000FF0000FE0000FC00007000001642
+79B92C>I<0F801FE03FF07FF87FF87FFC7FFC7FFC3FFC1FFC0FFC00FC00F800F801F803
+F007F01FE07FC0FF80FF00FC0070000E17718A2C>44 D<7FFFFFFF00FFFFFFFF80FFFFFF
+FF80FFFFFFFF80FFFFFFFF807FFFFFFF0021067B9B2C>I<1F003F807FC0FFE0FFE0FFE0
+FFE0FFE07FC03F801F000B0B708A2C>I<0003F80000000FFE0000003FFF8000007FFFC0
+0000FFFFE00001FE0FF00003F803F80007F001FC0007E000FC000FC0007E000FC0007E00
+1F80003F001F80003F003F00001F803F00001F803E00000F807E00000FC07E00000FC07E
+00000FC07C000007C0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC00
+0007E0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FE0000
+0FE07E00000FC07E00000FC07E00000FC07E00000FC03F00001F803F00001F803F00001F
+801F80003F001F80003F000FC0007E000FE000FE0007E000FC0007F001FC0003F803F800
+01FE0FF00000FFFFE000007FFFC000003FFF8000000FFE00000003F8000023357CB32C>
+48 D<00070000000F8000000F8000001F8000001F8000003F8000007F800000FF800001
+FF800007FF80007FFF8000FFFF8000FFDF8000FF9F80007C1F8000001F8000001F800000
+1F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F800000
+1F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F800000
+1F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F800000
+1F8000001F8000001F80007FFFFFE0FFFFFFF0FFFFFFF0FFFFFFF07FFFFFE01C3477B32C
+>I<000FF80000007FFF800001FFFFE00007FFFFF0000FFFFFFC001FF80FFE003FE001FF
+003F80007F007F00003F807E00001F80FE00001FC0FE00000FC0FF00000FE0FF000007E0
+FF000007E0FF000007E07E000007E03C000007E000000007E000000007E00000000FE000
+00000FC00000001FC00000001F800000003F800000003F000000007F00000000FE000000
+01FC00000003FC00000007F80000000FF00000001FE00000003FC0000000FF80000001FE
+00000003FC00000007F80000000FF00000003FE00000007F80000000FF00000001FE0000
+0003FC0003C007F80007E01FE00007E03FC00007E07FFFFFFFE0FFFFFFFFE0FFFFFFFFE0
+FFFFFFFFE07FFFFFFFC023347CB32C>I<000FFC0000007FFF800001FFFFE00007FFFFF8
+000FFFFFFC001FF807FE001FC000FE003F80007F003FC0003F003FC0003F803FC0001F80
+3FC0001F801F80001F800F00001F800000001F800000003F800000003F000000007F0000
+0000FE00000001FE00000003FC0000001FF800001FFFF000003FFFE000003FFFE000003F
+FFF800001FFFFC00000007FE00000000FF000000007F000000003F800000001FC0000000
+0FC00000000FC00000000FE000000007E000000007E03C000007E07E000007E0FF000007
+E0FF00000FE0FF00000FC0FF00000FC0FE00001FC07F00003F807F80007F003FC000FF00
+1FF807FE000FFFFFFC0007FFFFF80003FFFFE000007FFF8000000FFC000023357CB32C>
+I<000007F00000000FF80000001FF80000003FF80000003FF80000007EF80000007EF800
+0000FCF8000001F8F8000001F8F8000003F0F8000007E0F8000007E0F800000FC0F80000
+1F80F800001F80F800003F00F800007E00F800007E00F80000FC00F80001F800F80001F8
+00F80003F000F80003E000F80007E000F8000FC000F8000FC000F8001F8000F8003F0000
+F8003F0000F8007E0000F800FC0000F800FFFFFFFFFCFFFFFFFFFEFFFFFFFFFEFFFFFFFF
+FE7FFFFFFFFC000000F800000000F800000000F800000000F800000000F800000000F800
+000000F800000000F800000000F800000000F80000007FFFF00000FFFFF80000FFFFF800
+00FFFFF800007FFFF027347EB32C>I<0FFFFFFE001FFFFFFF001FFFFFFF001FFFFFFF00
+1FFFFFFE001F800000001F800000001F800000001F800000001F800000001F800000001F
+800000001F800000001F800000001F800000001F800000001F800000001F800000001F83
+FE00001F9FFF80001FFFFFE0001FFFFFF8001FFFFFFC001FFE03FE001FF000FF001FC000
+7F001F80003F801F00001F800F00001FC00000000FC00000000FC000000007E000000007
+E000000007E000000007E03C000007E07E000007E0FF000007E0FF00000FE0FF00000FC0
+FF00000FC0FE00001FC07E00003F807F00007F003F8000FF003FC001FE001FF80FFC000F
+FFFFF80007FFFFF00001FFFFC000007FFF0000000FF8000023347CB22C>I<00003FC000
+0001FFF8000007FFFC00001FFFFE00003FFFFF00007FE07F0000FF003F8001FE007F8003
+F8007F8007F0007F8007E0007F800FE0003F001FC0001E001F800000003F800000003F00
+0000003F000000007F000000007E000000007E03FE00007E1FFF8000FC7FFFE000FDFFFF
+F000FFFFFFF800FFFE07FC00FFF001FE00FFC0007F00FF80003F80FF00001F80FF00001F
+C0FE00000FC0FE00000FE0FE000007E0FE000007E0FE000007E07E000007E07E000007E0
+7E000007E07E000007E03F000007E03F00000FE03F80000FC01F80001FC01FC0001F800F
+C0003F800FE0007F0007F801FE0003FE07FC0001FFFFF80000FFFFF000007FFFE000001F
+FF80000007FC000023357CB32C>I<7800000000FFFFFFFFC0FFFFFFFFE0FFFFFFFFE0FF
+FFFFFFE0FFFFFFFFC0FC00003F80FC00007F00FC0000FE00780000FC00000001FC000000
+03F800000007F000000007E00000000FE00000000FC00000001F800000003F800000003F
+000000007F000000007E00000000FE00000000FC00000001FC00000001F800000001F800
+000003F000000003F000000007F000000007E000000007E000000007E00000000FC00000
+000FC00000000FC00000000FC00000001F800000001F800000001F800000001F80000000
+1F800000003F800000003F000000003F000000003F000000003F000000003F000000003F
+000000003F000000003F000000003F000000003F000000001E00000023357CB32C>I<00
+07FC0000003FFF800000FFFFE00003FFFFF80007FFFFFC000FFC07FE001FF001FF001FC0
+007F003F80003F803F00001F807F00001FC07E00000FC07E00000FC07E00000FC07E0000
+0FC07E00000FC03F00001F803F00001F801F80003F001FC0007F000FF001FE0003FC07F8
+0001FFFFF000007FFFC0000007FC0000007FFFC00001FFFFF00003FC07F8000FF001FE00
+1FC0007F001F80003F003F00001F807E00000FC07E00000FC0FC000007E0FC000007E0FC
+000007E0FC000007E0FC000007E0FC000007E0FC000007E07E00000FC07E00000FC07F00
+001FC03F80003F801FC0007F001FF001FF000FFC07FE0007FFFFFC0003FFFFF80000FFFF
+E000003FFF80000007FC000023357CB32C>I<0007FC0000003FFF000000FFFFC00001FF
+FFE00003FFFFF00007FC07F8000FF001FC001FE000FE003F80007E003F80007F007F0000
+3F007E00001F80FE00001F80FC00001F80FC00000FC0FC00000FC0FC00000FC0FC00000F
+C0FC00000FE0FC00000FE0FC00000FE0FE00000FE07E00000FE07F00001FE03F00001FE0
+3F80003FE01FC0007FE00FF001FFE007FC0FFFE003FFFFFFE001FFFFF7E000FFFFC7E000
+3FFF0FE0000FF80FC00000000FC00000000FC00000001FC00000001F800000003F800000
+003F000F00007F001F80007E003FC000FE003FC001FC003FC003F8003FC007F8003F801F
+F0001FE07FE0001FFFFFC0000FFFFF000007FFFE000001FFF80000007FC0000023357CB3
+2C>I<1F003F807FC0FFE0FFE0FFE0FFE0FFE07FC03F801F000000000000000000000000
+00000000000000000000000000000000001F003F807FC0FFE0FFE0FFE0FFE0FFE07FC03F
+801F000B2470A32C>I<7FFFFFFFF0FFFFFFFFF8FFFFFFFFF8FFFFFFFFF8FFFFFFFFF83F
+FFFFFFF00000000000000000000000000000000000000000000000000000000000000000
+00000000000000003FFFFFFFF0FFFFFFFFF8FFFFFFFFF8FFFFFFFFF8FFFFFFFFF87FFFFF
+FFF025147DA22C>61 D<7000000000FC00000000FE00000000FF80000000FFE00000007F
+F00000001FFC0000000FFE00000003FF80000000FFC00000007FF00000001FF80000000F
+FE00000003FF00000001FFC00000007FE00000003FF80000000FFC00000007FF00000001
+FF80000000FF80000000FF80000001FF80000007FF0000000FFC0000003FF80000007FE0
+000001FFC0000003FF0000000FFE0000001FF80000007FF0000000FFC0000003FF800000
+0FFE0000001FFC0000007FF0000000FFE0000000FF80000000FE00000000FC0000000070
+00000000212A7BAD2C>I<003FFE000003FFFFC0000FFFFFF0001FFFFFFC003FFFFFFE00
+7FE007FF007F0000FF00FE00003F80FF00001F80FF00001F80FF00001F80FF00003F807E
+00007F003C0000FF00000003FE0000000FFC0000001FF80000003FE00000007FC0000000
+FF00000001FE00000003FC00000003F800000007F800000007F00000000FF00000000FE0
+0000000FE00000000FE00000000FE00000000FE00000000FE00000000FE000000007C000
+000000000000000000000000000000000000000000000000000000000000000000000000
+00000000000003800000000FE00000000FE00000001FF00000001FF00000001FF0000000
+0FE00000000FE00000000380000021337BB22C>I<0000FE00000001FF00000001FF0000
+0001FF00000001FF00000003FF80000003FF80000003EF80000003EF80000007EF800000
+07EFC0000007EFC0000007C7C0000007C7C000000FC7E000000FC7E000000FC7E000000F
+C3E000001F83F000001F83F000001F83F000001F83F000001F83F000003F01F800003F01
+F800003F01F800003F01F800007E00FC00007E00FC00007E00FC00007E00FC00007E00FC
+0000FC007E0000FFFFFE0000FFFFFE0000FFFFFE0001FFFFFF0001FFFFFF0001F8003F00
+01F8003F0001F8003F0003F0001F8003F0001F8003F0001F8003F0001F8007F0001FC007
+E0000FC07FFE00FFFC7FFF01FFFCFFFF01FFFE7FFF01FFFC7FFE00FFFC27347EB32C>65
+D<0000FF00700007FFE0F8000FFFF9F8003FFFFDF8007FFFFFF800FF81FFF801FE007FF8
+03FC001FF807F0000FF807F00007F80FE00007F80FC00003F81F800003F81F800001F83F
+000001F83F000001F87F000001F87E000000F07E000000007E00000000FE00000000FC00
+000000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC0000
+0000FC00000000FC00000000FC00000000FE000000007E000000007E000000007E000000
+007F000000F03F000001F83F000001F81F800001F81F800001F80FC00003F80FE00003F0
+07F00007F007F00007E003FC001FE001FE003FC000FF81FF80007FFFFF00003FFFFE0000
+0FFFFC000007FFF0000000FF800025357DB32C>67 D<7FFFFF0000FFFFFFC000FFFFFFF0
+00FFFFFFF8007FFFFFFC0007E003FE0007E000FF0007E0007F8007E0003F8007E0001FC0
+07E0000FE007E0000FE007E00007E007E00007F007E00003F007E00003F807E00001F807
+E00001F807E00001F807E00001F807E00000FC07E00000FC07E00000FC07E00000FC07E0
+0000FC07E00000FC07E00000FC07E00000FC07E00000FC07E00000FC07E00000FC07E000
+00FC07E00001F807E00001F807E00001F807E00003F807E00003F007E00003F007E00007
+F007E00007E007E0000FE007E0001FC007E0003FC007E0007F8007E000FF0007E003FE00
+7FFFFFFC00FFFFFFF800FFFFFFF000FFFFFFC0007FFFFF000026337EB22C>I<7FE0000F
+FCFFF0001FFEFFF0001FFEFFF8003FFE7FF8003FFC0FF8003FE00FBC007BE00FBC007BE0
+0FBC007BE00FBC007BE00F9E00F3E00F9E00F3E00F9E00F3E00F9F01F3E00F9F01F3E00F
+8F01E3E00F8F01E3E00F8F83E3E00F8F83E3E00F8783C3E00F87C7C3E00F87C7C3E00F83
+C783E00F83C783E00F83EF83E00F83EF83E00F81EF03E00F81EF03E00F81FF03E00F80FE
+03E00F80FE03E00F80FE03E00F807C03E00F803803E00F800003E00F800003E00F800003
+E00F800003E00F800003E00F800003E00F800003E00F800003E00F800003E00F800003E0
+0F800003E00F800003E07FF0001FFCFFF8003FFEFFF8003FFEFFF8003FFE7FF0001FFC27
+337EB22C>77 D<7FFFFFC000FFFFFFF800FFFFFFFC00FFFFFFFF007FFFFFFF8003F000FF
+C003F0003FC003F0000FE003F00007F003F00007F003F00003F003F00003F803F00001F8
+03F00001F803F00001F803F00001F803F00001F803F00001F803F00003F803F00003F003
+F00007F003F00007F003F0000FE003F0003FC003F000FFC003FFFFFF8003FFFFFF0003FF
+FFFC0003FFFFF80003FFFFC00003F000000003F000000003F000000003F000000003F000
+000003F000000003F000000003F000000003F000000003F000000003F000000003F00000
+0003F000000003F000000003F000000003F00000007FFF800000FFFFC00000FFFFC00000
+FFFFC000007FFF80000025337EB22C>80 D<7FFFFFFFFCFFFFFFFFFEFFFFFFFFFEFFFFFF
+FFFEFFFFFFFFFEFC007E007EFC007E007EFC007E007EFC007E007EFC007E007EFC007E00
+7EFC007E007E78007E003C00007E000000007E000000007E000000007E000000007E0000
+00007E000000007E000000007E000000007E000000007E000000007E000000007E000000
+007E000000007E000000007E000000007E000000007E000000007E000000007E00000000
+7E000000007E000000007E000000007E000000007E000000007E000000007E000000007E
+000000007E000000007E000000007E000000007E000000007E000000007E0000003FFFFC
+00003FFFFC00007FFFFE00003FFFFC00003FFFFC0027337EB22C>84
+D<7FFFFCFFFFFEFFFFFEFFFFFEFFFFFCFC0000FC0000FC0000FC0000FC0000FC0000FC00
+00FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC00
+00FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC00
+00FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC00
+00FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC0000FC00
+00FFFFFCFFFFFEFFFFFEFFFFFE7FFFFC17416FB92C>91 D<7FFFFCFFFFFEFFFFFEFFFFFE
+7FFFFE00007E00007E00007E00007E00007E00007E00007E00007E00007E00007E00007E
+00007E00007E00007E00007E00007E00007E00007E00007E00007E00007E00007E00007E
+00007E00007E00007E00007E00007E00007E00007E00007E00007E00007E00007E00007E
+00007E00007E00007E00007E00007E00007E00007E00007E00007E00007E00007E00007E
+00007E00007E00007E00007E00007E00007E00007E00007E7FFFFEFFFFFEFFFFFEFFFFFE
+7FFFFC17417DB92C>93 D<007000F801F803F807F00FE01FC01F803F003E007E007C007C
+00FC00F800F800F800F800FF80FFC0FFE0FFE07FE07FE03FE01FC00F800D1B71B82C>96
+D<01FFF0000007FFFE00001FFFFF80001FFFFFE0003FFFFFF0003FC01FF8003FC007F800
+3FC001FC001F8000FC00060000FE000000007E000000007E000000007E000000FFFE0000
+1FFFFE0000FFFFFE0003FFFFFE000FFFFFFE001FFF807E003FF8007E007FC0007E007F00
+007E00FE00007E00FC00007E00FC00007E00FC00007E00FC00007E00FE00007E007F0000
+FE007F8003FE003FE01FFE001FFFFFFFFC0FFFFFFFFE07FFFFBFFE01FFFE1FFE003FF007
+FC27247CA32C>I<7FF0000000FFF8000000FFF8000000FFF80000007FF800000001F800
+000001F800000001F800000001F800000001F800000001F800000001F800000001F80000
+0001F800000001F800000001F81FE00001F8FFF80001FBFFFE0001FFFFFF0001FFFFFF80
+01FFF07FC001FF801FE001FF0007F001FE0003F801FC0003F801FC0001FC01F80000FC01
+F80000FC01F80000FE01F800007E01F800007E01F800007E01F800007E01F800007E01F8
+00007E01F800007E01F800007E01F80000FE01FC0000FC01FC0000FC01FC0001F801FE00
+03F801FF0007F001FF000FF001FF801FE001FFE07FC001FFFFFF8001FFFFFF0001FBFFFE
+0001F8FFF80000F03FC00027337FB22C>I<0003FFE000001FFFF800007FFFFE0001FFFF
+FE0003FFFFFF0007FE00FF000FF000FF001FE000FF001FC0007E003F800018003F000000
+007F000000007E000000007E00000000FC00000000FC00000000FC00000000FC00000000
+FC00000000FC00000000FC00000000FC000000007E000000007E000000007F000000003F
+00000F003F80001F801FC0001F801FE0003F800FF0007F0007FE03FF0003FFFFFE0001FF
+FFFC00007FFFF800001FFFE0000003FF000021247AA32C>I<00000FFE0000001FFF0000
+001FFF0000001FFF0000000FFF000000003F000000003F000000003F000000003F000000
+003F000000003F000000003F000000003F000000003F000000003F000007F83F00003FFE
+3F0000FFFFBF0001FFFFFF0003FFFFFF0007FC0FFF000FF003FF001FE001FF001FC000FF
+003F80007F003F00007F007E00003F007E00003F00FE00003F00FC00003F00FC00003F00
+FC00003F00FC00003F00FC00003F00FC00003F00FC00003F00FC00003F00FE00003F007E
+00007F007E00007F007F0000FF003F8000FF003F8001FF001FC003FF000FF007FF0007FC
+1FFF0003FFFFFFFC01FFFFBFFE00FFFF3FFE003FFC3FFE000FF01FFC27337DB22C>I<00
+03FE0000001FFFC000007FFFF00001FFFFF80003FFFFFC0007FE03FE000FF800FF001FE0
+003F801FC0003F803F80001FC03F00000FC07F00000FC07E00000FE07E000007E0FC0000
+07E0FFFFFFFFE0FFFFFFFFE0FFFFFFFFE0FFFFFFFFE0FFFFFFFFC0FC00000000FE000000
+007E000000007E000000007F000000003F000003C03F800007E01FC00007E00FF0000FE0
+07F8003FC007FF00FFC001FFFFFF8000FFFFFF00003FFFFC00000FFFF0000001FF800023
+247CA32C>I<00000FF80000003FFE000000FFFF000001FFFF800003FFFF800007FC7F80
+0007F07F80000FE03F00000FC03F00000FC00000000FC00000000FC00000000FC0000000
+0FC00000000FC000007FFFFFFE00FFFFFFFF00FFFFFFFF00FFFFFFFF007FFFFFFE00000F
+C00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC0
+0000000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC000
+00000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000
+000FC00000000FC00000000FC00000000FC000003FFFFFF0007FFFFFF8007FFFFFF8007F
+FFFFF8003FFFFFF00021337DB22C>I<00000003F80007F80FFC001FFE3FFE007FFFFFFF
+01FFFFFFFF03FFFFFE7F03FC0FF87F07F003F83E0FE001FC1C0FC000FC001FC000FE001F
+80007E001F80007E001F80007E001F80007E001F80007E001F80007E001FC000FE000FC0
+00FC000FE001FC0007F003F80003FC0FF00007FFFFF00007FFFFE0000FFFFF80000F9FFE
+00000F87F800000F800000000F800000000F800000000FC000000007E000000007FFFFF0
+0003FFFFFE0007FFFFFF800FFFFFFFE01FFFFFFFF03FC0001FF87F000003FC7E000000FC
+7C0000007CFC0000007EF80000003EF80000003EF80000003EF80000003EFC0000007E7E
+000000FC7F800003FC3FE0000FF81FFC007FF00FFFFFFFE003FFFFFF8001FFFFFF00003F
+FFF8000007FFC00028387EA42C>I<7FF000000000FFF800000000FFF800000000FFF800
+0000007FF80000000001F80000000001F80000000001F80000000001F80000000001F800
+00000001F80000000001F80000000001F80000000001F80000000001F80000000001F81F
+E0000001F87FFC000001F9FFFE000001FBFFFF000001FFFFFF000001FFF03F800001FFC0
+1F800001FF801FC00001FF000FC00001FE000FC00001FC000FC00001FC000FC00001F800
+0FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F800
+0FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F800
+0FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F800
+0FC0007FFFE0FFFF00FFFFF1FFFF80FFFFF1FFFF80FFFFF1FFFF807FFFE0FFFF0029337F
+B22C>I<00070000001FC000001FC000003FE000003FE000003FE000001FC000001FC000
+00070000000000000000000000000000000000000000000000000000000000007FFFC000
+7FFFE000FFFFE0007FFFE0007FFFE0000007E0000007E0000007E0000007E0000007E000
+0007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E000
+0007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E0000007E000
+0007E0000007E0000007E0007FFFFFFCFFFFFFFEFFFFFFFEFFFFFFFE7FFFFFFC1F3479B3
+2C>I<00000E0000003F8000003F8000007FC000007FC000007FC000003F8000003F8000
+000E000000000000000000000000000000000000000000000000000000000001FFFF8003
+FFFFC003FFFFC003FFFFC001FFFFC000000FC000000FC000000FC000000FC000000FC000
+000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000
+000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000
+000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000000FC000
+000FC000000FC000000FC000000FC000000FC000000FC000001FC03C001F807E003F80FF
+003F00FF007F00FF01FE00FFFFFC007FFFF8007FFFF0001FFFE00007FF00001A467CB32C
+>I<7FE0000000FFF0000000FFF0000000FFF00000007FF000000001F000000001F00000
+0001F000000001F000000001F000000001F000000001F000000001F000000001F0000000
+01F000000001F01FFFF001F03FFFF801F03FFFF801F03FFFF801F01FFFF001F000FE0001
+F001FC0001F003F80001F007F00001F00FE00001F01FC00001F03F800001F07F000001F0
+FE000001F1FC000001F3FC000001F7FE000001FFFF000001FFFF000001FF9F800001FF0F
+C00001FE0FE00001FC07E00001F803F00001F001F80001F001FC0001F000FC0001F0007E
+0001F0003F0001F0003F8001F0001F807FFFC0FFFCFFFFE1FFFEFFFFE1FFFEFFFFE1FFFE
+7FFFC0FFFC27337EB22C>I<7FFFE00000FFFFF00000FFFFF00000FFFFF000007FFFF000
+000003F000000003F000000003F000000003F000000003F000000003F000000003F00000
+0003F000000003F000000003F000000003F000000003F000000003F000000003F0000000
+03F000000003F000000003F000000003F000000003F000000003F000000003F000000003
+F000000003F000000003F000000003F000000003F000000003F000000003F000000003F0
+00000003F000000003F000000003F000000003F000000003F000000003F000000003F000
+000003F000000003F000000003F000000003F000000003F000007FFFFFFF80FFFFFFFFC0
+FFFFFFFFC0FFFFFFFFC07FFFFFFF8022337BB22C>I<7F83F007E0007FCFFC1FF800FFDF
+FE3FFC007FFFFEFFFC007FFFFFFFFE0007FE1FFC3E0007FC1FF83F0007F80FF01F0007F0
+0FE01F0007E00FC01F0007E00FC01F0007E00FC01F0007C00F801F0007C00F801F0007C0
+0F801F0007C00F801F0007C00F801F0007C00F801F0007C00F801F0007C00F801F0007C0
+0F801F0007C00F801F0007C00F801F0007C00F801F0007C00F801F0007C00F801F0007C0
+0F801F0007C00F801F0007C00F801F0007C00F801F0007C00F801F007FFC3FF87FF07FFC
+7FF8FFF0FFFE7FFCFFF87FFC7FF8FFF07FFC3FF87FF02D2481A32C>I<7FF01FE00000FF
+F87FFC0000FFF9FFFE0000FFFBFFFF00007FFFFFFF000001FFF03F800001FFC01F800001
+FF801FC00001FF000FC00001FE000FC00001FC000FC00001FC000FC00001F8000FC00001
+F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001
+F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001
+F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC0007F
+FFE0FFFF00FFFFF1FFFF80FFFFF1FFFF80FFFFF1FFFF807FFFE0FFFF0029247FA32C>I<
+0007FC0000001FFF0000007FFFC00001FFFFF00003FFFFF80007FC07FC000FF001FE001F
+E000FF001F80003F003F80003F803F00001F807E00000FC07E00000FC07E00000FC0FC00
+0007E0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FC000007E0FE0000
+0FE07E00000FC07E00000FC07F00001FC03F00001F803F80003F801FC0007F001FE000FF
+000FF001FE0007FC07FC0003FFFFF80001FFFFF000007FFFC000001FFF00000007FC0000
+23247CA32C>I<7FF01FE000FFF8FFF800FFFBFFFE00FFFFFFFF007FFFFFFF8001FFF07F
+C001FF801FE001FF0007F001FE0003F801FC0003F801FC0001FC01F80000FC01F80000FC
+01F80000FE01F800007E01F800007E01F800007E01F800007E01F800007E01F800007E01
+F800007E01F800007E01F80000FE01FC0000FC01FC0000FC01FC0001F801FE0003F801FF
+0007F001FF000FF001FF801FE001FFE07FC001FFFFFF8001FFFFFF0001FBFFFE0001F8FF
+F80001F83FC00001F800000001F800000001F800000001F800000001F800000001F80000
+0001F800000001F800000001F800000001F800000001F800000001F800000001F8000000
+7FFFE00000FFFFF00000FFFFF00000FFFFF000007FFFE0000027367FA32C>I<0003FC07
+8000001FFF0FC000007FFFCFC00001FFFFEFC00003FFFFFFC00007FE07FFC0000FF001FF
+C0001FE000FFC0001FC0007FC0003F80003FC0003F00003FC0007F00001FC0007E00001F
+C0007E00000FC000FC00000FC000FC00000FC000FC00000FC000FC00000FC000FC00000F
+C000FC00000FC000FC00000FC000FC00000FC000FE00000FC0007E00001FC0007E00001F
+C0003F00003FC0003F80003FC0001FC0007FC0001FE000FFC0000FF003FFC00007FC0FFF
+C00003FFFFFFC00001FFFFEFC000007FFF8FC000003FFF0FC0000007F80FC0000000000F
+C0000000000FC0000000000FC0000000000FC0000000000FC0000000000FC0000000000F
+C0000000000FC0000000000FC0000000000FC0000000000FC0000000000FC0000000000F
+C000000003FFFF00000007FFFF80000007FFFF80000007FFFF80000003FFFF0029367DA3
+2C>I<7FFE003FC0FFFF01FFF0FFFF07FFF8FFFF1FFFFC7FFF3FFFFC003F7FE1FC003FFF
+01FC003FFC00F8003FF80070003FF00000003FE00000003FE00000003FC00000003F8000
+00003F800000003F800000003F000000003F000000003F000000003F000000003F000000
+003F000000003F000000003F000000003F000000003F000000003F000000003F00000000
+3F000000003F000000003F0000007FFFFFE000FFFFFFF000FFFFFFF000FFFFFFF0007FFF
+FFE00026247EA32C>I<007FF87003FFFFF80FFFFFF81FFFFFF83FFFFFF87FC00FF87E00
+03F8FC0001F8F80001F8F80001F8F80001F8FC0000F07F0000007FF000003FFFC0001FFF
+FE000FFFFF8003FFFFE0007FFFF80001FFFC000007FC000000FE7800007FFC00003FFC00
+001FFE00001FFE00001FFF00003FFF80003EFFC000FEFFF007FCFFFFFFFCFFFFFFF8FFFF
+FFE0F8FFFF80701FFC0020247AA32C>I<001E000000003F000000003F000000003F0000
+00003F000000003F000000003F000000003F000000003F000000003F0000007FFFFFFF00
+FFFFFFFF80FFFFFFFF80FFFFFFFF807FFFFFFF00003F000000003F000000003F00000000
+3F000000003F000000003F000000003F000000003F000000003F000000003F000000003F
+000000003F000000003F000000003F000000003F000000003F000000003F000000003F00
+03C0003F0007E0003F0007E0003F0007E0003F0007E0003F0007E0003F800FE0001F801F
+C0001FE07FC0000FFFFF80000FFFFF000003FFFE000001FFF80000003FE000232E7EAD2C
+>I<7FF003FF8000FFF807FFC000FFF807FFC000FFF807FFC0007FF803FFC00001F8000F
+C00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000F
+C00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000F
+C00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000FC00001F8000F
+C00001F8000FC00001F8000FC00001F8001FC00001F8001FC00001F8003FC00001FC007F
+C00000FE03FFC00000FFFFFFFF00007FFFFFFF80003FFFFFFF80001FFFCFFF800003FE07
+FF0029247FA32C>I<7FFF01FFFCFFFF01FFFEFFFF83FFFEFFFF01FFFE7FFF01FFFC03E0
+000F8003E0000F8003F0001F8001F0001F0001F0001F0001F8003F0000F8003E0000F800
+3E0000FC007E00007C007C00007C007C00007E00FC00003E00F800003E00F800003F01F8
+00001F01F000001F01F000001F83F000000F83E000000F83E000000FC7E0000007C7C000
+0007C7C0000007EFC0000003EF80000003EF80000003FF80000001FF00000001FF000000
+00FE000000007C000027247EA32C>I<7FFF007FFF007FFF80FFFF00FFFF80FFFF807FFF
+80FFFF007FFF007FFF0007C00001F00007C00001F00007C00001F00007C00001F00007C0
+0001F00007C00001F00003E00003E00003E00003E00003E00003E00003E03E03E00003E0
+7F03E00003E07F03E00001F07F07C00001F0FF87C00001F0FF87C00001F0F787C00001F0
+F787C00001F1F7C7C00000F1F7C7800000F9E3CF800000F9E3CF800000FBE3EF800000FB
+E3EF800000FBE3EF8000007BC1EF0000007FC1FF0000007FC1FF0000007F80FF0000007F
+80FF0000003F80FE0000001F007C000029247FA32C>I<3FFF03FFF07FFF87FFF87FFF87
+FFF87FFF87FFF83FFF03FFF000FC007E0000FC00FC00007E01F800003F01F000001F83F0
+00001F87E000000FCFC0000007EF80000003FF80000001FF00000001FE00000000FC0000
+00007C00000000FE00000001FE00000001FF00000003EF80000007CFC000000FC7C00000
+0F83E000001F01F000003F01F800007E00F800007C007C0000F8007E0001F8003F007FFF
+01FFFC7FFF83FFFCFFFF83FFFE7FFF83FFFC7FFF01FFFC27247EA32C>I<7FFF01FFFCFF
+FF81FFFEFFFF83FFFEFFFF81FFFE7FFF01FFFC03E0000F8001F0000F8001F0001F8001F8
+001F0000F8001F0000F8003F0000FC003E00007C003E00007E007E00003E007C00003E00
+7C00003F00FC00001F00F800001F00F800000F81F800000F81F000000F81F0000007C1F0
+000007C3E0000007C3E0000003E3E0000003E7C0000001E7C0000001F7C0000001F78000
+0000FF80000000FF80000000FF000000007F000000007F000000003E000000003E000000
+007E000000007C000000007C00000000FC00000000F800000000F800000C01F800003F01
+F000007F83F000007F87E000007E0FE000007E1FC000007FFF8000003FFF0000001FFE00
+00000FFC00000007E000000027367EA32C>I E /Ff 57 123 df<00000FF800FC000000
+7FFF07FF000001F807DF83C00007E001FF0FC0001F8007FE1FE0003F000FFC1FE0007E00
+0FFC1FE0007E000FF81FE000FC000FF81FE000FC000FF0078001F80007F0000001F80003
+F0000001F80003F0000001F80003F0000001F80003F0000001F80003F0000001F80003F0
+000001F80003F0000001F80003F0000001F80003F0000001F80003F0000001F80003F000
+0001F80003F00000FFFFFFFFFFF800FFFFFFFFFFF800FFFFFFFFFFF80001F80003F00000
+01F80003F0000001F80003F0000001F80003F0000001F80003F0000001F80003F0000001
+F80003F0000001F80003F0000001F80003F0000001F80003F0000001F80003F0000001F8
+0003F0000001F80003F0000001F80003F0000001F80003F0000001F80003F0000001F800
+03F0000001F80003F0000001F80003F0000001F80003F0000001F80003F0000001F80003
+F0000001F80003F0000001F80003F0000001F80003F0000001F80003F0000001F80003F0
+000001F80003F0000001F80003F0000003FC0007F800007FFFE0FFFFF0007FFFE0FFFFF0
+007FFFE0FFFFF000333B7FBA30>11 D<00000FF8000000007FFE00000001F80780000007
+E001C000001F8000E000003F0007E000007E000FF000007E000FF00000FC000FF00000FC
+000FF00001F8000FF00001F80007E00001F80001800001F80000000001F80000000001F8
+0000000001F80000000001F80000000001F80000000001F80000000001F80000000001F8
+0000000001F80003F000FFFFFFFFF000FFFFFFFFF000FFFFFFFFF00001F8000FF00001F8
+0003F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003F00001F8
+0003F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003F00001F8
+0003F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003F00001F8
+0003F00001F80003F00001F80003F00001F80003F00001F80003F00001F80003F00001F8
+0003F00001F80003F00001F80003F00001F80003F00003FC0007F8007FFFE0FFFFC07FFF
+E0FFFFC07FFFE0FFFFC02A3B7FBA2E>I<1C007F00FF80FF80FFC0FFC0FFC07FC01CC000
+C000C000C000C001C00180018003800300070006000E001C003800700060000A1979B917
+>39 D<0000600000E00001C0000380000700000E00001E00003C0000780000780000F000
+01E00001E00003C00003C00007C0000780000F80000F00000F00001F00001E00001E0000
+3E00003E00003E00007C00007C00007C00007C00007C00007C0000F80000F80000F80000
+F80000F80000F80000F80000F80000F80000F80000F80000F80000F80000F80000F80000
+F80000F80000F800007C00007C00007C00007C00007C00007C00003E00003E00003E0000
+1E00001E00001F00000F00000F00000F800007800007C00003C00003C00001E00001E000
+00F000007800007800003C00001E00000E000007000003800001C00000E0000060135278
+BD20>I<C00000E000007000003800001C00000E00000F000007800003C00003C00001E0
+0000F00000F000007800007800007C00003C00003E00001E00001E00001F00000F00000F
+00000F80000F80000F800007C00007C00007C00007C00007C00007C00003E00003E00003
+E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003E00003
+E00003E00003E00003E00007C00007C00007C00007C00007C00007C0000F80000F80000F
+80000F00000F00001F00001E00001E00003E00003C00007C0000780000780000F00000F0
+0001E00003C00003C0000780000F00000E00001C0000380000700000E00000C000001352
+7CBD20>I<1C007F00FF80FF80FFC0FFC0FFC07FC01CC000C000C000C000C001C0018001
+8003800300070006000E001C003800700060000A19798817>44 D<FFFFFCFFFFFCFFFFFC
+FFFFFCFFFFFC16057F941C>I<1C007F00FF80FF80FF80FF80FF807F001C000909798817>
+I<0001C0000003C0000007C000001FC00000FFC000FFFFC000FFFFC000FF1FC000001FC0
+00001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC0
+00001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC0
+00001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC0
+00001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC0
+00001FC000001FC000001FC000001FC000001FC000001FC000001FC000003FE0007FFFFF
+F07FFFFFF07FFFFFF01C3879B72A>49 D<000FF00000007FFE000001FFFF800003E03FE0
+000F000FF0000E0007F8001C0003FC00380001FE00300001FE00700000FF00600000FF00
+FC0000FF00FF00007F80FF80007F80FF80007F80FF80007F80FF80007F80FF80007F807F
+00007F801C00007F800000007F80000000FF00000000FF00000000FF00000001FE000000
+01FC00000003FC00000003F800000007F000000007E00000000FE00000001FC00000003F
+800000003F000000007C00000000F800000001F000000003E000000007C00000000F8000
+00000F000000001E000180003C000180007800018000F000038001E000030003C0000300
+07800003000E000007000FFFFFFF001FFFFFFF003FFFFFFF007FFFFFFE00FFFFFFFE00FF
+FFFFFE00FFFFFFFE0021387CB72A>I<0007F80000003FFF0000007FFFC00001F80FF000
+03C007F800078003FC000E0001FC000F0001FE001FE000FE001FF000FF001FF000FF001F
+F000FF001FF000FF001FF000FF000FE000FF0007C000FF00000000FE00000001FE000000
+01FE00000001FC00000003F800000003F800000007F000000007E00000000F800000007E
+0000001FFC0000001FFF800000000FE000000007F000000001FC00000001FE00000000FF
+000000007F800000007F800000007FC00000007FC00000003FC00000003FE00000003FE0
+1E00003FE07F80003FE0FFC0003FE0FFC0003FE0FFC0003FE0FFC0003FE0FFC0003FC0FF
+80007FC07F80007F807E00007F80700000FF00380001FE001E0001FE000F8003F80007F0
+0FF00001FFFFC000007FFF0000000FF80000233A7DB72A>I<0000003800000000380000
+00007800000000F800000000F800000001F800000003F800000007F800000007F8000000
+0FF80000001FF80000001BF800000033F800000073F800000063F8000000C3F8000001C3
+F800000183F800000303F800000703F800000603F800000C03F800001C03F800001803F8
+00003003F800007003F800006003F80000C003F80001C003F800038003F800030003F800
+070003F8000E0003F8000C0003F800180003F800380003F800300003F800600003F800E0
+0003F800FFFFFFFFF8FFFFFFFFF8FFFFFFFFF8000003F800000003F800000003F8000000
+03F800000003F800000003F800000003F800000003F800000003F800000003F800000003
+F800000007FC000003FFFFF80003FFFFF80003FFFFF825397EB82A>I<0600000C000780
+003C0007F003F80007FFFFF80007FFFFF00007FFFFE00007FFFF800007FFFF000007FFFC
+0000067FE000000600000000060000000006000000000600000000060000000006000000
+00060000000006000000000600000000060000000006000000000607F80000063FFE0000
+06780F800007E007E000078003F000070001F800060001F800060000FC00000000FE0000
+0000FE00000000FF000000007F000000007F000000007F800000007F800000007F800000
+007F803E00007F807F00007F80FF80007F80FF80007F80FF80007F80FF80007F80FF0000
+7F00FE0000FF00E00000FF00600000FE00700000FE00300001FC00380001F8001C0003F8
+001E0007F0000F800FE00007E03F800001FFFF0000007FFC0000001FE00000213A7CB72A
+>I<00003FC0000001FFF0000007FFFC00000FE03E00003F800700007E001F0000FC003F
+8001F8007F8003F0007F8003F0007F8007E0007F800FE0003F000FC0001E001FC0000000
+1FC00000003F800000003F800000003F800000007F800000007F000000007F01FC00007F
+07FF8000FF1E07E000FF3801F000FF7000F800FF6000FC00FFE0007E00FFC0003F00FFC0
+003F00FF80003F80FF80003FC0FF80001FC0FF80001FC0FF00001FE0FF00001FE0FF0000
+1FE0FF00001FE0FF00001FE07F00001FE07F00001FE07F00001FE07F00001FE07F00001F
+E03F80001FE03F80001FC03F80001FC01F80001FC01F80003F801FC0003F800FC0003F00
+07E0007F0007E000FE0003F000FC0001F801F80000FE07F000003FFFC000001FFF000000
+03FC0000233A7DB72A>I<300000000038000000003E000000003FFFFFFFE03FFFFFFFE0
+3FFFFFFFE03FFFFFFFC07FFFFFFFC07FFFFFFF807FFFFFFF0070000006006000000E0060
+00001C006000001800E000003800C000007000C00000E000C00000C000000001C0000000
+0380000000030000000007000000000E000000000C000000001C00000000380000000038
+0000000070000000007000000000F000000001E000000001E000000003E000000003E000
+000003C000000007C000000007C00000000FC00000000FC00000000FC00000001F800000
+001F800000001F800000003F800000003F800000003F800000003F800000003F80000000
+7F800000007F800000007F800000007F800000007F800000007F800000007F800000007F
+800000007F800000003F000000001E000000233B7BB82A>I<1C007F00FF80FF80FF80FF
+80FF807F001C000000000000000000000000000000000000000000000000000000000000
+000000000000001C007F00FF80FF80FF80FF80FF807F001C00092479A317>58
+D<1C007F00FF80FF80FF80FF80FF807F001C000000000000000000000000000000000000
+000000000000000000000000000000000000001C007F00FF00FF80FF80FF80FF807F801D
+8001800180018001800380030003000700060006000E001C001800380070006000093479
+A317>I<0000003800000000000038000000000000380000000000007C0000000000007C
+0000000000007C000000000000FE000000000000FE000000000000FE000000000001FF00
+0000000001FF000000000001FF0000000000037F8000000000037F8000000000077FC000
+000000063FC000000000063FC0000000000E3FE0000000000C1FE0000000000C1FE00000
+00001C1FF000000000180FF000000000180FF000000000380FF8000000003007F8000000
+003007F8000000007007FC000000006003FC000000006003FC00000000C003FE00000000
+C001FE00000000C001FE000000018001FF000000018000FF000000018000FF0000000300
+00FF8000000300007F8000000300007F8000000600007FC0000007FFFFFFC0000007FFFF
+FFC000000FFFFFFFE000000C00001FE000000C00001FE000001800000FF000001800000F
+F000001800000FF0000030000007F8000030000007F8000030000007F8000060000003FC
+000060000003FC0000E0000003FC0000E0000001FE0001E0000001FE0003F0000001FF00
+0FFC000007FF80FFFF8000FFFFFEFFFF8000FFFFFEFFFF8000FFFFFE373C7DBB3E>65
+D<FFFFFFFFE00000FFFFFFFFFC0000FFFFFFFFFF000001FF80007FC00000FF00001FE000
+00FF00000FF00000FF000007F80000FF000003FC0000FF000003FC0000FF000001FE0000
+FF000001FE0000FF000001FF0000FF000001FF0000FF000001FF0000FF000001FF0000FF
+000001FF0000FF000001FF0000FF000001FF0000FF000001FE0000FF000003FE0000FF00
+0003FC0000FF000007F80000FF00000FF00000FF00001FE00000FF00003FC00000FF0000
+FF800000FFFFFFFC000000FFFFFFFC000000FF00007F800000FF00001FE00000FF000007
+F00000FF000003F80000FF000001FC0000FF000001FE0000FF000000FF0000FF000000FF
+0000FF000000FF8000FF0000007F8000FF0000007FC000FF0000007FC000FF0000007FC0
+00FF0000007FC000FF0000007FC000FF0000007FC000FF0000007FC000FF0000007F8000
+FF000000FF8000FF000000FF8000FF000001FF0000FF000001FE0000FF000003FE0000FF
+000007FC0000FF00001FF80001FF80007FF000FFFFFFFFFFC000FFFFFFFFFF0000FFFFFF
+FFF8000032397DB83B>I<000001FF80018000000FFFE0038000007FFFF803800001FF80
+7E07800003FC000F0F80000FF000039F80001FE00001DF80003F800000FF80007F000000
+7F8000FE0000003F8001FE0000003F8003FC0000001F8007F80000000F8007F80000000F
+800FF000000007800FF000000007801FE000000007801FE000000003803FE00000000380
+3FC000000003807FC000000001807FC000000001807FC000000001807F800000000180FF
+800000000000FF800000000000FF800000000000FF800000000000FF800000000000FF80
+0000000000FF800000000000FF800000000000FF800000000000FF800000000000FF8000
+00000000FF800000000000FF8000000000007F8000000000007FC000000001807FC00000
+0001807FC000000001803FC000000001803FE000000001801FE000000003801FE0000000
+03000FF000000003000FF0000000070007F8000000070007F8000000060003FC0000000E
+0001FE0000001C0000FE0000001800007F0000003800003F8000007000001FE00000E000
+000FF00003C0000003FC000F80000001FF803F000000007FFFFC000000000FFFF0000000
+0001FF800000313D7BBA3C>I<FFFFFFFFC00000FFFFFFFFF80000FFFFFFFFFE000001FF
+8001FF800000FF00003FE00000FF00000FF00000FF000003F80000FF000001FC0000FF00
+0000FE0000FF0000007F0000FF0000007F0000FF0000003F8000FF0000003FC000FF0000
+001FC000FF0000001FE000FF0000000FE000FF0000000FF000FF0000000FF000FF000000
+0FF000FF00000007F800FF00000007F800FF00000007F800FF00000007F800FF00000007
+FC00FF00000007FC00FF00000007FC00FF00000007FC00FF00000007FC00FF00000007FC
+00FF00000007FC00FF00000007FC00FF00000007FC00FF00000007FC00FF00000007FC00
+FF00000007FC00FF00000007F800FF00000007F800FF00000007F800FF00000007F800FF
+0000000FF000FF0000000FF000FF0000000FE000FF0000000FE000FF0000001FE000FF00
+00001FC000FF0000003F8000FF0000003F8000FF0000007F0000FF000000FE0000FF0000
+01FC0000FF000003F80000FF00000FF00000FF00003FE00001FF8000FF8000FFFFFFFFFF
+0000FFFFFFFFF80000FFFFFFFFC0000036397DB83F>I<FFFFFFFFFFFC00FFFFFFFFFFFC
+00FFFFFFFFFFFC0001FF80000FFC0000FF000001FC0000FF0000007E0000FF0000003E00
+00FF0000001E0000FF0000000E0000FF0000000E0000FF0000000E0000FF000000060000
+FF000000060000FF000000060000FF000000070000FF000000030000FF0000C0030000FF
+0000C0030000FF0000C0030000FF0000C0000000FF0000C0000000FF0000C0000000FF00
+01C0000000FF0001C0000000FF0003C0000000FF000FC0000000FFFFFFC0000000FFFFFF
+C0000000FFFFFFC0000000FF000FC0000000FF0003C0000000FF0001C0000000FF0001C0
+000000FF0000C0000000FF0000C0000000FF0000C0006000FF0000C0006000FF0000C000
+6000FF0000C000E000FF00000000C000FF00000000C000FF00000000C000FF00000000C0
+00FF00000001C000FF00000001C000FF00000001C000FF000000038000FF000000038000
+FF000000078000FF000000078000FF0000000F8000FF0000003F8000FF0000007F8001FF
+800007FF00FFFFFFFFFFFF00FFFFFFFFFFFF00FFFFFFFFFFFF0033397DB839>I<FFFFFF
+FFFFF8FFFFFFFFFFF8FFFFFFFFFFF801FF80001FF800FF000001F800FF000000FC00FF00
+00007C00FF0000003C00FF0000001C00FF0000001C00FF0000000C00FF0000000C00FF00
+00000C00FF0000000C00FF0000000E00FF0000000600FF0000000600FF0001800600FF00
+01800600FF0001800000FF0001800000FF0001800000FF0001800000FF0003800000FF00
+03800000FF0007800000FF001F800000FFFFFF800000FFFFFF800000FFFFFF800000FF00
+1F800000FF0007800000FF0003800000FF0003800000FF0001800000FF0001800000FF00
+01800000FF0001800000FF0001800000FF0001800000FF0000000000FF0000000000FF00
+00000000FF0000000000FF0000000000FF0000000000FF0000000000FF0000000000FF00
+00000000FF0000000000FF0000000000FF0000000000FF0000000001FFC0000000FFFFFF
+C00000FFFFFFC00000FFFFFFC000002F397DB836>I<FFFFFFC0FFFFFFC0FFFFFFC000FF
+C000007F8000007F8000007F8000007F8000007F8000007F8000007F8000007F8000007F
+8000007F8000007F8000007F8000007F8000007F8000007F8000007F8000007F8000007F
+8000007F8000007F8000007F8000007F8000007F8000007F8000007F8000007F8000007F
+8000007F8000007F8000007F8000007F8000007F8000007F8000007F8000007F8000007F
+8000007F8000007F8000007F8000007F8000007F8000007F8000007F8000007F8000007F
+8000007F8000007F8000007F8000007F800000FFC000FFFFFFC0FFFFFFC0FFFFFFC01A39
+7EB81E>73 D<FFFFFFE00000FFFFFFE00000FFFFFFE0000001FFC000000000FF00000000
+00FF0000000000FF0000000000FF0000000000FF0000000000FF0000000000FF00000000
+00FF0000000000FF0000000000FF0000000000FF0000000000FF0000000000FF00000000
+00FF0000000000FF0000000000FF0000000000FF0000000000FF0000000000FF00000000
+00FF0000000000FF0000000000FF0000000000FF0000000000FF0000000000FF00000000
+00FF0000000000FF0000000000FF0000000000FF0000000000FF0000000000FF00000000
+00FF0000001800FF0000001800FF0000001800FF0000001800FF0000001800FF00000038
+00FF0000003000FF0000003000FF0000003000FF0000007000FF0000007000FF00000070
+00FF000000F000FF000000F000FF000001F000FF000003F000FF00000FF000FF00001FE0
+01FF8000FFE0FFFFFFFFFFE0FFFFFFFFFFE0FFFFFFFFFFE02D397DB834>76
+D<FFFF000007FFFEFFFF800007FFFEFFFFC00007FFFE00FFC000007FE000FFE000001F80
+00DFF000000F0000DFF00000060000CFF80000060000C7FC0000060000C7FC0000060000
+C3FE0000060000C1FF0000060000C1FF0000060000C0FF8000060000C07FC000060000C0
+7FC000060000C03FE000060000C01FF000060000C01FF800060000C00FF800060000C007
+FC00060000C007FE00060000C003FE00060000C001FF00060000C001FF80060000C000FF
+80060000C0007FC0060000C0007FE0060000C0003FE0060000C0001FF0060000C0000FF8
+060000C0000FF8060000C00007FC060000C00003FE060000C00003FE060000C00001FF06
+0000C00000FF860000C00000FF860000C000007FC60000C000003FE60000C000003FE600
+00C000001FF60000C000000FFE0000C000000FFE0000C0000007FE0000C0000003FE0000
+C0000003FE0000C0000001FE0000C0000000FE0000C0000000FE0000C00000007E0001E0
+0000003E0003F00000003E000FFC0000001E00FFFFC000000E00FFFFC000000E00FFFFC0
+0000060037397DB83E>78 D<000003FF00000000001FFFE000000000FE01FC00000001F8
+007E00000007E0001F8000000FC0000FC000003F800007F000007F000003F80000FE0000
+01FC0001FC000000FE0001F80000007E0003F80000007F0007F00000003F8007F0000000
+3F800FE00000001FC00FE00000001FC01FE00000001FE01FC00000000FE03FC00000000F
+F03FC00000000FF03FC00000000FF07FC00000000FF87F8000000007F87F8000000007F8
+7F8000000007F8FF8000000007FCFF8000000007FCFF8000000007FCFF8000000007FCFF
+8000000007FCFF8000000007FCFF8000000007FCFF8000000007FCFF8000000007FCFF80
+00000007FCFF8000000007FCFF8000000007FC7F8000000007F87FC00000000FF87FC000
+00000FF87FC00000000FF83FC00000000FF03FC00000000FF01FE00000001FE01FE00000
+001FE01FE00000001FE00FF00000003FC007F00000003F8007F80000007F8003F8000000
+7F0001FC000000FE0001FC000000FE0000FE000001FC00007F000003F800003F800007F0
+00001FC0000FE0000007E0001F80000003F8007F00000000FE01FC000000001FFFE00000
+000003FF000000363D7BBA41>I<FFFFFFFE00000000FFFFFFFFE0000000FFFFFFFFF800
+000001FF8007FE00000000FF0000FF80000000FF00003FC0000000FF00001FE0000000FF
+00000FF0000000FF000007F8000000FF000007F8000000FF000003FC000000FF000003FC
+000000FF000003FE000000FF000003FE000000FF000003FE000000FF000003FE000000FF
+000003FE000000FF000003FE000000FF000003FC000000FF000003FC000000FF000007F8
+000000FF000007F8000000FF00000FF0000000FF00001FE0000000FF00003F80000000FF
+0000FF00000000FF0007FC00000000FFFFFFE000000000FFFFFFC000000000FF000FF000
+000000FF0003F800000000FF0000FE00000000FF0000FF00000000FF00007F80000000FF
+00003FC0000000FF00003FC0000000FF00001FC0000000FF00001FE0000000FF00001FE0
+000000FF00001FE0000000FF00001FE0000000FF00001FE0000000FF00001FF0000000FF
+00001FF0000000FF00001FF0000000FF00001FF0000000FF00001FF0000000FF00001FF0
+000000FF00001FF0018000FF00001FF0018000FF00001FF8018000FF00000FF8018000FF
+00000FF8038001FF800007F80300FFFFFF0003FC0700FFFFFF0001FC0600FFFFFF0000FE
+0E0000000000003FFC00000000000007F000393B7DB83D>82 D<000FF800C0003FFE01C0
+00FFFF81C003F807E3C007E000F7C00FC0007FC01F80003FC03F00001FC03E00000FC07E
+000007C07E000007C07C000003C0FC000003C0FC000001C0FC000001C0FC000001C0FE00
+0000C0FE000000C0FE000000C0FF000000C0FF800000007FC00000007FE00000007FF800
+00003FFF8000001FFFF800001FFFFF80000FFFFFE00007FFFFF80003FFFFFE0000FFFFFF
+00003FFFFF800007FFFFC000007FFFC0000007FFE00000007FE00000003FF00000001FF0
+0000000FF000000007F800000007F8C0000003F8C0000003F8C0000001F8C0000001F8C0
+000001F8E0000001F8E0000001F8E0000001F0F0000001F0F0000003F0F8000003E0FC00
+0007E0FE000007C0FF00000FC0FF80001F80FBF0003F00F0FE00FE00E03FFFF800E00FFF
+E000C001FF0000253D7CBA2E>I<3FFFFFFFFFFFE03FFFFFFFFFFFE03FFFFFFFFFFFE03F
+C003FF001FE03E0001FE0003E07C0001FE0001F0780001FE0000F0700001FE0000707000
+01FE000070700001FE000070600001FE000030600001FE000030600001FE000030600001
+FE000030E00001FE000038C00001FE000018C00001FE000018C00001FE000018C00001FE
+000018000001FE000000000001FE000000000001FE000000000001FE000000000001FE00
+0000000001FE000000000001FE000000000001FE000000000001FE000000000001FE0000
+00000001FE000000000001FE000000000001FE000000000001FE000000000001FE000000
+000001FE000000000001FE000000000001FE000000000001FE000000000001FE00000000
+0001FE000000000001FE000000000001FE000000000001FE000000000001FE0000000000
+01FE000000000001FE000000000001FE000000000001FE000000000001FE000000000001
+FE000000000001FE000000000001FE000000000001FE000000000007FF800000001FFFFF
+FFE000001FFFFFFFE000001FFFFFFFE00035397DB83C>I<0180038007000E001C001800
+38003000700060006000E000C000C000C000C000CE00FF80FFC0FFC0FFC07FC07FC03F80
+0E000A197AB917>96 D<001FE0000000FFFC000003E03F000007000F80000F8007E0001F
+C003F0001FE003F0001FE001F8001FE001F8001FE000FC000FC000FC00078000FC000000
+00FC00000000FC00000000FC00000000FC0000007FFC000007FFFC00003FE0FC0000FE00
+FC0003F800FC000FF000FC001FC000FC003FC000FC007F8000FC007F0000FC007F0000FC
+0CFE0000FC0CFE0000FC0CFE0000FC0CFE0001FC0CFE0001FC0CFF0003FC0C7F00077C0C
+7F80063E183FC01E3E180FE0781FF003FFF00FE0007F8007C026277DA52A>I<03F00000
+00FFF0000000FFF0000000FFF00000000FF000000003F000000003F000000003F0000000
+03F000000003F000000003F000000003F000000003F000000003F000000003F000000003
+F000000003F000000003F000000003F000000003F000000003F000000003F01FE00003F0
+7FF80003F1E03E0003F3801F8003F7000FC003FE0007E003FC0003F003F80001F803F000
+01F803F00000FC03F00000FC03F00000FE03F00000FE03F000007E03F000007F03F00000
+7F03F000007F03F000007F03F000007F03F000007F03F000007F03F000007F03F000007F
+03F000007F03F000007E03F00000FE03F00000FE03F00000FC03F00001FC03F80001F803
+F80003F003FC0003F003EE0007E003C6000FC003C7801F000381E07E000300FFF8000000
+1FC000283B7EB92E>I<0003FC00001FFF80007E03E001F8007003F000F807E001FC0FC0
+03FC0FC003FC1F8003FC3F8003FC3F0001F87F0000F07F0000007F0000007E000000FE00
+0000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE000000FE00
+00007E0000007F0000007F0000003F0000063F8000061F80000E1FC0000C0FC0001C07E0
+003803F0007001F800E0007C07C0001FFF000007F8001F277DA525>I<0000000FC00000
+03FFC0000003FFC0000003FFC00000003FC00000000FC00000000FC00000000FC0000000
+0FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000F
+C00000000FC00000000FC00000000FC00000000FC00000000FC00003F80FC0001FFF0FC0
+007E078FC000F801EFC003F0007FC007E0003FC00FC0001FC00FC0001FC01F80000FC03F
+80000FC03F00000FC07F00000FC07F00000FC07E00000FC0FE00000FC0FE00000FC0FE00
+000FC0FE00000FC0FE00000FC0FE00000FC0FE00000FC0FE00000FC0FE00000FC0FE0000
+0FC07E00000FC07F00000FC07F00000FC03F00000FC03F00000FC01F80001FC01F80001F
+C00FC0003FC007E0007FC003F000EFF001F801CFFF007C078FFF001FFE0FFF0007F80FC0
+283B7DB92E>I<0007F800001FFF00007C0FC001F803E003F001F007E001F80FC000F81F
+80007C1F80007C3F00007E3F00003E7F00003E7F00003F7E00003FFE00003FFE00003FFE
+00003FFFFFFFFFFFFFFFFFFE000000FE000000FE000000FE000000FE0000007E0000007E
+0000007F0000007F0000003F0000033F8000031F8000070FC0000607C0000E07E0001C01
+F0003800F80070007E03E0001FFF800003FC0020277EA525>I<00007E000003FF80000F
+C1E0001F87E0003F0FF0007E0FF0007E0FF000FC0FF000FC0FF001F803C001F8000001F8
+000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8
+000001F8000001F80000FFFFFC00FFFFFC00FFFFFC0001F8000001F8000001F8000001F8
+000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8
+000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8
+000001F8000001F8000001F8000001F8000001F8000001F8000001F8000003FC00007FFF
+F8007FFFF8007FFFF8001C3B7FBA19>I<00000003F0000FF00FF8003FFC3C3C00F81F70
+7C01F00FE07C03E007C07C07C003E0100FC003F0000FC003F0001F8001F8001F8001F800
+1F8001F8001F8001F8001F8001F8001F8001F8001F8001F8001F8001F8000FC003F0000F
+C003F00007C003E00003E007C00003F00F800003F81F0000073FFC0000060FF000000E00
+0000000E000000000E000000000E000000000F000000000F000000000FC000000007FFFF
+C00007FFFFF80003FFFFFE0001FFFFFF8003FFFFFFC00F80007FE01F00000FF03E000003
+F07C000001F07C000001F8F8000000F8F8000000F8F8000000F8F8000000F8F8000000F8
+FC000001F87C000001F03E000003E03F000007E00F80000F8007E0003F0001FC01FC0000
+7FFFF0000007FF000026387EA52A>I<03F000000000FFF000000000FFF000000000FFF0
+000000000FF00000000003F00000000003F00000000003F00000000003F00000000003F0
+0000000003F00000000003F00000000003F00000000003F00000000003F00000000003F0
+0000000003F00000000003F00000000003F00000000003F00000000003F00000000003F0
+0FF0000003F03FFC000003F0F03F000003F1C01F800003F3800FC00003F7000FC00003FE
+000FC00003FC0007E00003FC0007E00003F80007E00003F80007E00003F80007E00003F0
+0007E00003F00007E00003F00007E00003F00007E00003F00007E00003F00007E00003F0
+0007E00003F00007E00003F00007E00003F00007E00003F00007E00003F00007E00003F0
+0007E00003F00007E00003F00007E00003F00007E00003F00007E00003F00007E00003F0
+0007E00003F00007E00003F00007E00007F8000FF000FFFFC1FFFF80FFFFC1FFFF80FFFF
+C1FFFF80293A7EB92E>I<0380000FE0001FF0001FF0001FF0001FF0001FF0000FE00003
+800000000000000000000000000000000000000000000000000000000000000003F000FF
+F000FFF000FFF00007F00003F00003F00003F00003F00003F00003F00003F00003F00003
+F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003
+F00003F00003F00003F00003F00003F00003F00003F00007F800FFFFC0FFFFC0FFFFC012
+387EB717>I<0001C00007F0000FF8000FF8000FF8000FF8000FF80007F00001C0000000
+0000000000000000000000000000000000000000000000000000000001F800FFF800FFF8
+00FFF80007F80001F80001F80001F80001F80001F80001F80001F80001F80001F80001F8
+0001F80001F80001F80001F80001F80001F80001F80001F80001F80001F80001F80001F8
+0001F80001F80001F80001F80001F80001F80001F80001F80001F80001F80001F80001F8
+0001F80001F80001F80001F83C01F87E01F8FF01F0FF03F0FF03F0FF03E0FE07C07C07C0
+3C0F000FFE0003F800154984B719>I<03F0000000FFF0000000FFF0000000FFF0000000
+0FF000000003F000000003F000000003F000000003F000000003F000000003F000000003
+F000000003F000000003F000000003F000000003F000000003F000000003F000000003F0
+00000003F000000003F000000003F000000003F001FFFC03F001FFFC03F001FFFC03F000
+7FC003F0007F0003F0007C0003F000700003F000E00003F001C00003F003800003F00700
+0003F01E000003F038000003F078000003F0FC000003F1FC000003F3FE000003F73F0000
+03FE3F800003F81F800003F00FC00003F00FE00003F007E00003F003F00003F001F80003
+F001FC0003F000FC0003F0007E0003F0007F0003F0003F0003F0003F8003F0001FC007F8
+003FF0FFFFC0FFFFFFFFC0FFFFFFFFC0FFFF283A7EB92C>I<03F000FFF000FFF000FFF0
+000FF00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F0
+0003F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F0
+0003F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F0
+0003F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F00003F0
+0003F00003F00007F800FFFFC0FFFFC0FFFFC0123A7EB917>I<03F00FF0001FE000FFF0
+3FFC007FF800FFF0F03F01E07E00FFF1C01F83803F000FF3800FC7001F8003F7000FCE00
+1F8003FE000FDC001F8003FC0007F8000FC003FC0007F8000FC003F80007F0000FC003F8
+0007F0000FC003F80007F0000FC003F00007E0000FC003F00007E0000FC003F00007E000
+0FC003F00007E0000FC003F00007E0000FC003F00007E0000FC003F00007E0000FC003F0
+0007E0000FC003F00007E0000FC003F00007E0000FC003F00007E0000FC003F00007E000
+0FC003F00007E0000FC003F00007E0000FC003F00007E0000FC003F00007E0000FC003F0
+0007E0000FC003F00007E0000FC003F00007E0000FC003F00007E0000FC003F00007E000
+0FC007F8000FF0001FE0FFFFC1FFFF83FFFFFFFFC1FFFF83FFFFFFFFC1FFFF83FFFF4025
+7EA445>I<03F00FF00000FFF03FFC0000FFF0F03F0000FFF1C01F80000FF3800FC00003
+F7000FC00003FE000FC00003FC0007E00003FC0007E00003F80007E00003F80007E00003
+F80007E00003F00007E00003F00007E00003F00007E00003F00007E00003F00007E00003
+F00007E00003F00007E00003F00007E00003F00007E00003F00007E00003F00007E00003
+F00007E00003F00007E00003F00007E00003F00007E00003F00007E00003F00007E00003
+F00007E00003F00007E00003F00007E00003F00007E00007F8000FF000FFFFC1FFFF80FF
+FFC1FFFF80FFFFC1FFFF8029257EA42E>I<0003FE0000000FFF8000003E03E00000F800
+F80001F0007C0003E0003E0007C0001F000F80000F801F80000FC01F000007C03F000007
+E03F000007E07E000003F07E000003F07E000003F07E000003F0FE000003F8FE000003F8
+FE000003F8FE000003F8FE000003F8FE000003F8FE000003F8FE000003F8FE000003F87E
+000003F07E000003F07F000007F03F000007E03F000007E01F80000FC00F80000F800FC0
+001F8007E0003F0003F0007E0000F800F800007E03F000001FFFC0000003FE000025277E
+A52A>I<03F01FE000FFF07FF800FFF1E07E00FFF3801F8007F7000FC003FE0007E003FC
+0003F003F80003F803F00001F803F00001FC03F00000FC03F00000FE03F00000FE03F000
+00FE03F000007F03F000007F03F000007F03F000007F03F000007F03F000007F03F00000
+7F03F000007F03F000007F03F000007F03F00000FE03F00000FE03F00000FE03F00001FC
+03F00001FC03F80003F803F80003F003FC0007F003FE000FE003F6000FC003F7803F0003
+F1E07E0003F0FFF80003F01FC00003F000000003F000000003F000000003F000000003F0
+00000003F000000003F000000003F000000003F000000003F000000003F000000007F800
+0000FFFFC00000FFFFC00000FFFFC0000028357EA42E>I<0003F800C0001FFE01C0007E
+0781C000FC01C3C003F000E3C007F00077C00FE00037C00FC0003FC01FC0001FC03F8000
+1FC03F80000FC07F00000FC07F00000FC07F00000FC0FE00000FC0FE00000FC0FE00000F
+C0FE00000FC0FE00000FC0FE00000FC0FE00000FC0FE00000FC0FE00000FC0FE00000FC0
+7F00000FC07F00000FC07F00000FC03F00000FC03F80001FC01F80001FC01FC0003FC00F
+C0003FC007E0007FC003F000EFC001F801CFC0007E078FC0001FFE0FC00007F80FC00000
+000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC0000000
+0FC00000000FC00000000FC00000000FC00000001FE0000003FFFF000003FFFF000003FF
+FF28357DA42C>I<07E01F00FFE07FC0FFE1E3E0FFE387F00FE707F003E607F003EE07F0
+03EC03E003FC008003F8000003F8000003F8000003F8000003F0000003F0000003F00000
+03F0000003F0000003F0000003F0000003F0000003F0000003F0000003F0000003F00000
+03F0000003F0000003F0000003F0000003F0000003F0000003F0000003F0000007F80000
+FFFFF000FFFFF000FFFFF0001C257EA421>I<00FF030003FFE7000F80FF001E003F003C
+001F0078000F0070000700F0000700F0000700F0000300F8000300F8000300FC000300FF
+0000007FE000007FFF00003FFFE0001FFFF8000FFFFC0003FFFE0000FFFF000007FF8000
+007F8000001F80C0000FC0C00007C0C00007C0E00003C0E00003C0E00003C0F00003C0F0
+000380F8000780FC000780FC000F00FF001E00F3C07C00E1FFF000C03F80001A277DA521
+>I<00180000001800000018000000180000001800000038000000380000003800000078
+0000007800000078000000F8000001F8000003F8000007F800001FFFFF00FFFFFF00FFFF
+FF0001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8
+000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8000001F8
+000001F800C001F800C001F800C001F800C001F800C001F800C001F800C001F800C001F8
+00C000FC01C000FC0180007C0380007E0300003F0700000FFE000001F8001A347FB220>
+I<03F00007E000FFF001FFE000FFF001FFE000FFF001FFE0000FF0001FE00003F00007E0
+0003F00007E00003F00007E00003F00007E00003F00007E00003F00007E00003F00007E0
+0003F00007E00003F00007E00003F00007E00003F00007E00003F00007E00003F00007E0
+0003F00007E00003F00007E00003F00007E00003F00007E00003F00007E00003F00007E0
+0003F00007E00003F00007E00003F00007E00003F0000FE00003F0000FE00003F0000FE0
+0003F0001FE00001F0001FE00001F8003FE00000F80077F80000FC00E7FF80003F03C7FF
+80001FFF87FF800003FC07E00029267EA42E>I<FFFF803FFEFFFF803FFEFFFF803FFE0F
+F8000FF007F00007E003F00003C003F800038001F800030001F800030000FC00060000FC
+00060000FE000E00007E000C00007E000C00003F001800003F001800003F803800001F80
+3000001F803000000FC06000000FC06000000FE060000007E0C0000007E0C0000003F180
+000003F180000003F180000001FB00000001FB00000001FF00000000FE00000000FE0000
+00007C000000007C000000007C00000000380000000038000027257EA32C>I<FFFF1FFF
+E03FFEFFFF1FFFE03FFEFFFF1FFFE03FFE0FF800FF000FF807F0007E0003E007F0007E00
+03C003F0003E00018003F0003E00018001F8003F00030001F8003F00030001F8003F0003
+0000FC003F80060000FC006F80060000FC006F800600007E00EFC00C00007E00C7C00C00
+007E00C7C00C00003F01C7E01800003F0183E01800003F8183F03800001F8383F0300000
+1F8301F03000001FC301F87000000FC600F86000000FC600F860000007E600FCC0000007
+EC007CC0000007EC007CC0000003FC007F80000003F8003F80000003F8003F80000001F8
+003F00000001F0001F00000001F0001F00000000F0001E00000000E0000E000000006000
+0C000037257EA33C>I<FFFF807FFF00FFFF807FFF00FFFF807FFF0003FE003FF00001FE
+001F800000FE001F0000007E001C0000003F00180000001F80300000001FC0700000000F
+C0E000000007E0C000000007F18000000003FB8000000001FF0000000000FE0000000000
+FE00000000007F00000000003F00000000007F80000000007FC000000000CFC000000001
+C7E00000000383F00000000703F80000000601F80000000C00FC0000001C007E00000038
+007F00000078003F000000F0001F800001F8001FC0000FF8003FF000FFFE00FFFF80FFFE
+00FFFF80FFFE00FFFF8029247FA32C>I<FFFF803FFEFFFF803FFEFFFF803FFE0FF8000F
+F007F00007C003F000038001F800038001F800030001FC00030000FC00060000FC000600
+007E000C00007E000C00007F000C00003F001800003F001800001F803000001F80300000
+1FC07000000FC06000000FC060000007E0C0000007E0C0000007F1C0000003F180000003
+F180000001FB00000001FB00000001FF00000000FE00000000FE000000007C000000007C
+000000007C00000000380000000038000000003000000000300000000070000000006000
+0000006000000000C000000000C000007C01C00000FE01800000FE03800000FE03000000
+FE06000000FC0E000000701C00000038380000001FF00000000FC000000027357EA32C>
+I<3FFFFFFC3FFFFFFC3F8003FC3E0003F83C0007F038000FE030000FE070001FC070003F
+8060007F8060007F006000FE006001FC006001FC000003F8000007F0000007F000000FE0
+00001FC000003F8000003F8000007F000600FE000600FE000601FC000603F8000607F800
+0E07F0000E0FE0000C1FC0001C1FC0001C3F80003C7F00007CFF0003FCFFFFFFFCFFFFFF
+FC1F247EA325>I E /Fg 31 122 df<000000780000000000FC0000000003FC00000000
+07FC000000001FFC00000000FFFC0000000FFFFC000007FFFFFC0000FFFFFFFC0000FFFF
+FFFC0000FFFF7FFC0000FFF07FFC0000F8007FFC000000007FFC000000007FFC00000000
+7FFC000000007FFC000000007FFC000000007FFC000000007FFC000000007FFC00000000
+7FFC000000007FFC000000007FFC000000007FFC000000007FFC000000007FFC00000000
+7FFC000000007FFC000000007FFC000000007FFC000000007FFC000000007FFC00000000
+7FFC000000007FFC000000007FFC000000007FFC000000007FFC000000007FFC00000000
+7FFC000000007FFC000000007FFC000000007FFC000000007FFC000000007FFC00000000
+7FFC000000007FFC000000007FFC000000007FFC000000007FFC000000007FFC00000000
+7FFC000000007FFC000000007FFC000000007FFC000000007FFC000000007FFC00000000
+7FFC000000007FFC000000007FFC000000007FFC000000007FFC000000007FFC00000000
+7FFC000000007FFC000000007FFC000000007FFC000000007FFC000000007FFC00000000
+7FFC000000007FFC000000007FFC000000007FFC00007FFFFFFFFFFE7FFFFFFFFFFE7FFF
+FFFFFFFE7FFFFFFFFFFE7FFFFFFFFFFE2F4E76CD43>49 D<00003FFE0000000003FFFFE0
+0000000FFFFFFC0000003FFFFFFF000000FFFFFFFFC00001FFC07FFFE00003FE000FFFF8
+0007F80003FFFC000FE00001FFFE001FC00000FFFF003F8000007FFF003FF000007FFF80
+7FF800003FFFC07FFC00003FFFC0FFFE00001FFFE0FFFF00001FFFE0FFFF00001FFFE0FF
+FF00000FFFF0FFFF00000FFFF0FFFF00000FFFF0FFFF00000FFFF0FFFF00000FFFF07FFE
+00000FFFF07FFE00000FFFF03FFC00000FFFF00FF000000FFFF003C000000FFFF0000000
+000FFFE0000000001FFFE0000000001FFFE0000000001FFFC0000000003FFFC000000000
+3FFF80000000003FFF80000000007FFF00000000007FFE0000000000FFFC0000000001FF
+F80000000001FFF00000000003FFE00000000003FFC00000000007FF80000000000FFF00
+000000001FFE00000000001FFC00000000003FF800000000007FE00000000000FFC00000
+000001FF800000000003FE000000000007FC000000000007F800000000000FF00001F000
+001FE00001F000003F800001F000007F000001F00000FE000003E00001FC000003E00003
+F8000003E00007F0000003E0000FE0000003E0001F80000007E0003F00000007E0003E00
+00000FE0007FFFFFFFFFE000FFFFFFFFFFC001FFFFFFFFFFC003FFFFFFFFFFC007FFFFFF
+FFFFC00FFFFFFFFFFFC01FFFFFFFFFFFC03FFFFFFFFFFFC07FFFFFFFFFFFC0FFFFFFFFFF
+FFC0FFFFFFFFFFFF80FFFFFFFFFFFF80FFFFFFFFFFFF80FFFFFFFFFFFF80344E79CD43>
+I<00000FFFC000000000FFFFFC00000007FFFFFF8000001FFFFFFFE000003FF807FFF000
+00FF8001FFFC0001FE00007FFE0003F800003FFF0003F000003FFF8007FC00001FFF800F
+FF00001FFFC00FFF80001FFFC01FFFC0001FFFE01FFFC0001FFFE01FFFC0001FFFE01FFF
+C0001FFFE01FFFE0001FFFE01FFFC0001FFFE01FFFC0001FFFE01FFFC0001FFFE00FFFC0
+001FFFC007FF80001FFFC003FF00003FFFC001FC00003FFF80000000003FFF8000000000
+7FFF00000000007FFE00000000007FFE0000000000FFFC0000000001FFF80000000003FF
+F00000000007FFC0000000000FFF8000000000FFFE00000000FFFFF800000000FFFFE000
+000000FFFFFC00000000FFFFFF800000000007FFE00000000001FFF800000000007FFE00
+000000003FFF00000000001FFF80000000000FFFC0000000000FFFE00000000007FFF000
+00000007FFF00000000007FFF80000000007FFF80000000003FFFC0000000003FFFC0000
+000003FFFE0000000003FFFE03E0000003FFFE0FF8000003FFFE1FFC000003FFFE3FFE00
+0003FFFE7FFF000003FFFEFFFF800003FFFEFFFF800003FFFEFFFF800003FFFEFFFF8000
+03FFFCFFFF800003FFFCFFFF800007FFFCFFFF800007FFF8FFFF000007FFF87FFF000007
+FFF07FFE00000FFFF03FFC00000FFFE03FF000001FFFC01FE000003FFF800FF800007FFF
+0007FF0000FFFE0003FFF007FFFC0000FFFFFFFFF000007FFFFFFFE000001FFFFFFF8000
+0003FFFFFC000000001FFF800000374F7ACD43>I<00000000007C00000000000000FE00
+000000000000FE00000000000001FE00000000000003FE00000000000007FE0000000000
+000FFE0000000000000FFE0000000000001FFE0000000000003FFE0000000000007FFE00
+00000000007FFE000000000000FFFE000000000001FFFE000000000003FFFE0000000000
+03FFFE000000000007FFFE00000000000FFFFE00000000001FBFFE00000000003F3FFE00
+000000003E3FFE00000000007C3FFE0000000000FC3FFE0000000001F83FFE0000000001
+F03FFE0000000003E03FFE0000000007E03FFE000000000FC03FFE000000000F803FFE00
+0000001F003FFE000000003F003FFE000000007E003FFE000000007C003FFE00000000F8
+003FFE00000001F8003FFE00000003F0003FFE00000007E0003FFE00000007C0003FFE00
+00000F80003FFE0000001F80003FFE0000003F00003FFE0000003E00003FFE0000007C00
+003FFE000000FC00003FFE000001F800003FFE000001F000003FFE000003E000003FFE00
+0007E000003FFE00000FC000003FFE00001F8000003FFE00001F0000003FFE00003E0000
+003FFE00007E0000003FFE0000FC0000003FFE0000FFFFFFFFFFFFFFC0FFFFFFFFFFFFFF
+C0FFFFFFFFFFFFFFC0FFFFFFFFFFFFFFC0FFFFFFFFFFFFFFC0000000007FFE0000000000
+007FFE0000000000007FFE0000000000007FFE0000000000007FFE0000000000007FFE00
+00000000007FFE0000000000007FFE0000000000007FFE0000000000007FFE0000000000
+007FFE0000000000007FFE0000000000007FFE0000000000007FFE0000000000007FFE00
+0000000FFFFFFFFFC000000FFFFFFFFFC000000FFFFFFFFFC000000FFFFFFFFFC000000F
+FFFFFFFFC03A4F7CCE43>I<03800000000E0007E00000007E0007FE000003FE0007FFF0
+007FFE0007FFFFFFFFFC0007FFFFFFFFF80007FFFFFFFFF00007FFFFFFFFE00007FFFFFF
+FFC00007FFFFFFFF800007FFFFFFFF000007FFFFFFFE000007FFFFFFFC000007FFFFFFF0
+000007FFFFFFC0000007FFFFFF00000007FFFFF800000007E1FF0000000007E000000000
+0007E0000000000007E0000000000007E0000000000007E0000000000007E00000000000
+07E0000000000007E0000000000007E0000000000007E0000000000007E0000000000007
+E00FFF00000007E07FFFF0000007E3FFFFFE000007E7FFFFFF800007FFF807FFC00007FF
+C001FFE00007FE0000FFF80007FC00007FFC0007F800003FFC0007F000003FFE0007E000
+001FFF0003C000001FFF80000000001FFF80000000001FFFC0000000000FFFC000000000
+0FFFE0000000000FFFE0000000000FFFE0000000000FFFE0000000000FFFF0000000000F
+FFF0000000000FFFF00FE000000FFFF01FF000000FFFF03FF800000FFFF07FFC00000FFF
+F0FFFE00000FFFF0FFFE00000FFFF0FFFE00000FFFF0FFFE00000FFFF0FFFE00000FFFE0
+FFFE00000FFFE0FFFE00000FFFE0FFFC00000FFFE07FF800001FFFC07FF000001FFFC07F
+E000001FFF803E0000003FFF803F0000003FFF001F8000007FFE001FC000007FFC000FE0
+0000FFF80007F80001FFF00003FE0007FFE00001FFC03FFFC00000FFFFFFFF8000003FFF
+FFFE0000001FFFFFF800000003FFFFC0000000007FF8000000344F79CD43>I<0000000F
+FF0000000000FFFFE000000007FFFFF00000001FFFFFFC0000007FFE03FE000001FFF000
+7F000003FFC0003F800007FF00001F80000FFE00007FC0001FFC0000FFC0003FF80001FF
+E0007FF00003FFE000FFF00007FFE001FFE00007FFE001FFE00007FFE003FFC00007FFE0
+07FFC00007FFE007FFC00007FFE00FFFC00003FFC00FFF800001FF801FFF800000FF001F
+FF8000007E001FFF80000000003FFF80000000003FFF80000000003FFF00000000007FFF
+00000000007FFF00000000007FFF00080000007FFF01FFF800007FFF07FFFF0000FFFF0F
+FFFFC000FFFF1FFFFFF000FFFF3F007FF800FFFF3C003FFC00FFFF78001FFE00FFFFF000
+0FFF00FFFFF00007FF80FFFFE00007FFC0FFFFE00007FFC0FFFFC00007FFE0FFFFC00003
+FFF0FFFF800003FFF0FFFF800003FFF8FFFF800003FFF8FFFF800003FFF8FFFF800003FF
+F8FFFF000003FFFCFFFF000003FFFCFFFF000003FFFC7FFF000003FFFC7FFF000003FFFC
+7FFF000003FFFC7FFF000003FFFC7FFF000003FFFC7FFF000003FFFC3FFF000003FFFC3F
+FF000003FFFC3FFF000003FFFC3FFF000003FFFC1FFF000003FFF81FFF800003FFF81FFF
+800003FFF80FFF800003FFF80FFF800003FFF007FF800007FFF007FF800007FFE003FFC0
+0007FFC001FFC00007FFC001FFE0000FFF8000FFF0000FFF00007FF8001FFE00003FFC00
+7FFC00001FFF01FFF800000FFFFFFFF0000003FFFFFFC0000000FFFFFF000000003FFFFC
+0000000007FFC00000364F7ACD43>I<00000000001F00000000000000000000003F8000
+0000000000000000007FC0000000000000000000007FC000000000000000000000FFE000
+000000000000000000FFE000000000000000000000FFE000000000000000000001FFF000
+000000000000000001FFF000000000000000000003FFF800000000000000000003FFF800
+000000000000000003FFF800000000000000000007FFFC00000000000000000007FFFC00
+000000000000000007FFFC0000000000000000000FFFFE0000000000000000000FFFFE00
+00000000000000001FFFFF0000000000000000001FFFFF0000000000000000001FFFFF00
+00000000000000003FFFFF8000000000000000003F7FFF8000000000000000007F7FFFC0
+00000000000000007E7FFFC000000000000000007E3FFFC00000000000000000FE3FFFE0
+0000000000000000FC1FFFE00000000000000001FC1FFFF00000000000000001F81FFFF0
+0000000000000001F80FFFF00000000000000003F80FFFF80000000000000003F007FFF8
+0000000000000007F007FFFC0000000000000007E007FFFC0000000000000007E003FFFC
+000000000000000FE003FFFE000000000000000FC001FFFE000000000000001FC001FFFF
+000000000000001F8001FFFF000000000000001F8000FFFF000000000000003F8000FFFF
+800000000000003F00007FFF800000000000007F00007FFFC00000000000007E00007FFF
+C00000000000007E00003FFFC0000000000000FE00003FFFE0000000000000FC00001FFF
+E0000000000001FC00001FFFF0000000000001F800001FFFF0000000000001F800000FFF
+F0000000000003F800000FFFF8000000000003F0000007FFF8000000000007F0000007FF
+FC000000000007E0000007FFFC000000000007E0000003FFFC00000000000FFFFFFFFFFF
+FE00000000000FFFFFFFFFFFFE00000000001FFFFFFFFFFFFF00000000001FFFFFFFFFFF
+FF00000000001FFFFFFFFFFFFF00000000003F80000000FFFF80000000003F000000007F
+FF80000000007F000000007FFFC0000000007F000000007FFFC0000000007E000000003F
+FFC000000000FE000000003FFFE000000000FC000000001FFFE000000001FC000000001F
+FFF000000001FC000000001FFFF000000001F8000000000FFFF000000003F8000000000F
+FFF800000003F00000000007FFF800000007F00000000007FFFC00000007F00000000007
+FFFC00000007E00000000003FFFC0000000FE00000000003FFFE0000000FC00000000003
+FFFE0000001FC00000000001FFFF000000FFFC0000000001FFFF0000FFFFFFF800000FFF
+FFFFFFE0FFFFFFF800000FFFFFFFFFE0FFFFFFF800000FFFFFFFFFE0FFFFFFF800000FFF
+FFFFFFE0FFFFFFF800000FFFFFFFFFE05B547BD366>65 D<FFFFFFFFFFFFFFC0000000FF
+FFFFFFFFFFFFFE000000FFFFFFFFFFFFFFFFC00000FFFFFFFFFFFFFFFFF00000FFFFFFFF
+FFFFFFFFFC00000007FFF0000003FFFF00000007FFF00000007FFF80000007FFF0000000
+3FFFC0000007FFF00000000FFFE0000007FFF000000007FFF0000007FFF000000007FFF8
+000007FFF000000003FFF8000007FFF000000003FFFC000007FFF000000001FFFC000007
+FFF000000001FFFE000007FFF000000000FFFE000007FFF000000000FFFE000007FFF000
+000000FFFF000007FFF000000000FFFF000007FFF000000000FFFF000007FFF000000000
+FFFF000007FFF000000000FFFF000007FFF000000000FFFF000007FFF000000000FFFF00
+0007FFF000000000FFFF000007FFF000000001FFFE000007FFF000000001FFFE000007FF
+F000000001FFFC000007FFF000000003FFFC000007FFF000000003FFF8000007FFF00000
+0007FFF8000007FFF000000007FFF0000007FFF00000000FFFE0000007FFF00000001FFF
+C0000007FFF00000007FFF00000007FFF0000001FFFE00000007FFF0000007FFF8000000
+07FFFFFFFFFFFFE000000007FFFFFFFFFFFF0000000007FFFFFFFFFFFF8000000007FFFF
+FFFFFFFFF000000007FFF0000003FFFE00000007FFF00000003FFF80000007FFF0000000
+0FFFE0000007FFF000000007FFF0000007FFF000000001FFF8000007FFF000000001FFFC
+000007FFF000000000FFFE000007FFF0000000007FFF000007FFF0000000007FFF800007
+FFF0000000003FFFC00007FFF0000000003FFFC00007FFF0000000001FFFE00007FFF000
+0000001FFFE00007FFF0000000001FFFE00007FFF0000000001FFFF00007FFF000000000
+1FFFF00007FFF0000000001FFFF00007FFF0000000000FFFF00007FFF0000000000FFFF0
+0007FFF0000000000FFFF00007FFF0000000001FFFF00007FFF0000000001FFFF00007FF
+F0000000001FFFF00007FFF0000000001FFFE00007FFF0000000001FFFE00007FFF00000
+00003FFFE00007FFF0000000003FFFC00007FFF0000000003FFFC00007FFF0000000007F
+FF800007FFF000000000FFFF800007FFF000000000FFFF000007FFF000000001FFFE0000
+07FFF000000007FFFE000007FFF00000000FFFFC000007FFF00000003FFFF0000007FFF0
+000001FFFFE000FFFFFFFFFFFFFFFFFF8000FFFFFFFFFFFFFFFFFF0000FFFFFFFFFFFFFF
+FFF80000FFFFFFFFFFFFFFFFC00000FFFFFFFFFFFFFFF800000054527CD160>I<000000
+0001FFFC000001C0000000007FFFFFC00003C000000007FFFFFFF80007C00000003FFFFF
+FFFE001FC0000000FFFFFFFFFF803FC0000003FFFFE003FFC07FC000000FFFFC00003FF0
+FFC000003FFFE000000FF9FFC000007FFF80000003FFFFC00001FFFE00000000FFFFC000
+03FFF8000000007FFFC00007FFF0000000003FFFC0000FFFE0000000001FFFC0001FFFC0
+000000000FFFC0003FFF800000000007FFC0007FFF000000000003FFC000FFFE00000000
+0001FFC000FFFE000000000001FFC001FFFC000000000000FFC003FFF8000000000000FF
+C003FFF80000000000007FC007FFF00000000000007FC00FFFF00000000000003FC00FFF
+F00000000000003FC01FFFE00000000000001FC01FFFE00000000000001FC01FFFE00000
+000000001FC03FFFC00000000000001FC03FFFC00000000000000FC03FFFC00000000000
+000FC07FFFC00000000000000FC07FFFC00000000000000FC07FFFC00000000000000000
+7FFF8000000000000000007FFF800000000000000000FFFF800000000000000000FFFF80
+0000000000000000FFFF800000000000000000FFFF800000000000000000FFFF80000000
+0000000000FFFF800000000000000000FFFF800000000000000000FFFF80000000000000
+0000FFFF800000000000000000FFFF800000000000000000FFFF800000000000000000FF
+FF800000000000000000FFFF800000000000000000FFFF8000000000000000007FFF8000
+000000000000007FFF8000000000000000007FFFC000000000000000007FFFC000000000
+000000007FFFC000000000000007C03FFFC000000000000007C03FFFC000000000000007
+C03FFFC000000000000007C01FFFE000000000000007C01FFFE000000000000007C01FFF
+E00000000000000FC00FFFF00000000000000F800FFFF00000000000000F8007FFF00000
+000000001F8003FFF80000000000001F8003FFF80000000000001F0001FFFC0000000000
+003F0000FFFE0000000000007E0000FFFE0000000000007E00007FFF000000000000FC00
+003FFF800000000001F800001FFFC00000000003F800000FFFE00000000007F0000007FF
+F0000000000FE0000003FFFC000000001FC0000001FFFE000000007F800000007FFF8000
+0000FF000000003FFFE0000007FE000000000FFFFE00001FF80000000003FFFFE001FFF0
+0000000000FFFFFFFFFFC000000000003FFFFFFFFF00000000000007FFFFFFFC00000000
+0000007FFFFFE00000000000000001FFFC00000000525479D261>I<FFFFFFFFFFFFFFFF
+FE00FFFFFFFFFFFFFFFFFE00FFFFFFFFFFFFFFFFFE00FFFFFFFFFFFFFFFFFE00FFFFFFFF
+FFFFFFFFFE000007FFF8000007FFFF000007FFF80000007FFF000007FFF80000001FFF00
+0007FFF800000007FF000007FFF800000003FF000007FFF800000001FF000007FFF80000
+0000FF000007FFF8000000007F000007FFF8000000003F000007FFF8000000003F800007
+FFF8000000003F800007FFF8000000001F800007FFF8000000001F800007FFF800000000
+1F800007FFF8000000000F800007FFF8000000000F800007FFF8000000000F800007FFF8
+000000000F800007FFF8000000000FC00007FFF80000F80007C00007FFF80000F80007C0
+0007FFF80000F80007C00007FFF80000F80007C00007FFF80000F80000000007FFF80000
+F80000000007FFF80000F80000000007FFF80001F80000000007FFF80001F80000000007
+FFF80001F80000000007FFF80003F80000000007FFF80007F80000000007FFF8000FF800
+00000007FFF8007FF80000000007FFFFFFFFF80000000007FFFFFFFFF80000000007FFFF
+FFFFF80000000007FFFFFFFFF80000000007FFFFFFFFF80000000007FFF8007FF8000000
+0007FFF8000FF80000000007FFF80007F80000000007FFF80003F80000000007FFF80001
+F80000000007FFF80001F80000000007FFF80001F80000000007FFF80000F80000000007
+FFF80000F80000000007FFF80000F80000000007FFF80000F80000000007FFF80000F800
+00000007FFF80000F80000000007FFF80000F80000000007FFF80000000000000007FFF8
+0000000000000007FFF80000000000000007FFF80000000000000007FFF8000000000000
+0007FFF80000000000000007FFF80000000000000007FFF80000000000000007FFF80000
+000000000007FFF80000000000000007FFF80000000000000007FFF80000000000000007
+FFF80000000000000007FFF80000000000000007FFF80000000000000007FFF800000000
+00000007FFF80000000000000007FFF80000000000000007FFF8000000000000FFFFFFFF
+FFF800000000FFFFFFFFFFF800000000FFFFFFFFFFF800000000FFFFFFFFFFF800000000
+FFFFFFFFFFF8000000004A517CD055>70 D<FFFFFFFFFFC003FFFFFFFFFFFFFFFFFFFFC0
+03FFFFFFFFFFFFFFFFFFFFC003FFFFFFFFFFFFFFFFFFFFC003FFFFFFFFFFFFFFFFFFFFC0
+03FFFFFFFFFF0007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFFFFFFF
+FFFFFFFFE0000007FFFFFFFFFFFFFFFFE0000007FFFFFFFFFFFFFFFFE0000007FFFFFFFF
+FFFFFFFFE0000007FFFFFFFFFFFFFFFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE0000007FFF8000000001FFFE0000007FFF8000000001FFFE0000007FFF80000
+00001FFFE000FFFFFFFFFFC003FFFFFFFFFFFFFFFFFFFFC003FFFFFFFFFFFFFFFFFFFFC0
+03FFFFFFFFFFFFFFFFFFFFC003FFFFFFFFFFFFFFFFFFFFC003FFFFFFFFFF60527CD169>
+72 D<FFFFFFFFFFC0FFFFFFFFFFC0FFFFFFFFFFC0FFFFFFFFFFC0FFFFFFFFFFC00007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF800000007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF800000007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF800000007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF800000007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF800000007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF800000007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF800000007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF800000007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF800000007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF800000007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF800000007FF
+F800000007FFF800000007FFF800000007FFF800000007FFF800000007FFF80000FFFFFF
+FFFFC0FFFFFFFFFFC0FFFFFFFFFFC0FFFFFFFFFFC0FFFFFFFFFFC02A527CD132>I<FFFF
+FFFFFFFFF00000000000FFFFFFFFFFFFFF8000000000FFFFFFFFFFFFFFF800000000FFFF
+FFFFFFFFFFFF00000000FFFFFFFFFFFFFFFFC00000000007FFF00000FFFFF00000000007
+FFF000000FFFF80000000007FFF0000001FFFE0000000007FFF0000000FFFF0000000007
+FFF00000007FFF8000000007FFF00000003FFFC000000007FFF00000001FFFC000000007
+FFF00000000FFFE000000007FFF00000000FFFF000000007FFF00000000FFFF000000007
+FFF000000007FFF800000007FFF000000007FFF800000007FFF000000007FFF800000007
+FFF000000007FFFC00000007FFF000000007FFFC00000007FFF000000007FFFC00000007
+FFF000000007FFFC00000007FFF000000007FFFC00000007FFF000000007FFFC00000007
+FFF000000007FFFC00000007FFF000000007FFFC00000007FFF000000007FFF800000007
+FFF000000007FFF800000007FFF00000000FFFF800000007FFF00000000FFFF000000007
+FFF00000000FFFE000000007FFF00000000FFFE000000007FFF00000001FFFC000000007
+FFF00000003FFF8000000007FFF00000007FFF0000000007FFF0000000FFFE0000000007
+FFF0000003FFFC0000000007FFF000000FFFF00000000007FFF00000FFFFC00000000007
+FFFFFFFFFFFF000000000007FFFFFFFFFFF8000000000007FFFFFFFFFFE0000000000007
+FFFFFFFFFFF8000000000007FFF00003FFFE000000000007FFF000007FFF800000000007
+FFF000003FFFC00000000007FFF000001FFFE00000000007FFF000000FFFF00000000007
+FFF0000007FFF80000000007FFF0000003FFFC0000000007FFF0000003FFFE0000000007
+FFF0000001FFFE0000000007FFF0000001FFFE0000000007FFF0000001FFFF0000000007
+FFF0000000FFFF0000000007FFF0000000FFFF0000000007FFF0000000FFFF0000000007
+FFF0000000FFFF0000000007FFF0000000FFFF0000000007FFF0000000FFFF0000000007
+FFF0000000FFFF0000000007FFF0000000FFFF8000000007FFF0000000FFFF8000000007
+FFF0000000FFFF8000000007FFF0000000FFFF8000000007FFF0000000FFFF8000000007
+FFF0000000FFFF8000000007FFF0000000FFFF8000000007FFF0000000FFFF80001C0007
+FFF0000000FFFFC0003E0007FFF0000000FFFFC0003E0007FFF0000000FFFFC0003E0007
+FFF00000007FFFC0003E0007FFF00000007FFFE0007E0007FFF00000003FFFE0007C0007
+FFF00000003FFFF000FC0007FFF00000001FFFF001FCFFFFFFFFFF80000FFFF803F8FFFF
+FFFFFF800003FFFE07F0FFFFFFFFFF800001FFFFFFE0FFFFFFFFFF8000007FFFFFC0FFFF
+FFFFFF8000000FFFFF000000000000000000007FFC005F537CD164>82
+D<00000FFF800007000000FFFFF8000F000007FFFFFF001F00001FFFFFFFC03F00003FFF
+FFFFF07F0000FFFC00FFF8FF0001FFE0000FFDFF0003FF800001FFFF0007FE0000007FFF
+000FFC0000003FFF000FF80000000FFF001FF800000007FF001FF000000003FF003FF000
+000003FF003FE000000001FF007FE000000000FF007FE000000000FF007FE0000000007F
+00FFE0000000007F00FFE0000000003F00FFE0000000003F00FFF0000000003F00FFF000
+0000003F00FFF8000000001F00FFF8000000001F00FFFC000000001F00FFFE000000001F
+00FFFF000000000000FFFFC000000000007FFFF000000000007FFFFF00000000007FFFFF
+F8000000003FFFFFFF800000003FFFFFFFFC0000001FFFFFFFFFC000001FFFFFFFFFF000
+000FFFFFFFFFFC000007FFFFFFFFFF000003FFFFFFFFFFC00001FFFFFFFFFFE00000FFFF
+FFFFFFF000007FFFFFFFFFF800003FFFFFFFFFFC00000FFFFFFFFFFE000003FFFFFFFFFE
+000000FFFFFFFFFF0000001FFFFFFFFF80000000FFFFFFFF800000000FFFFFFFC0000000
+007FFFFFC00000000007FFFFE00000000000FFFFE000000000003FFFE000000000000FFF
+F0000000000007FFF0000000000003FFF0000000000003FFF0780000000001FFF0F80000
+000000FFF0F80000000000FFF0F80000000000FFF0F800000000007FF0F800000000007F
+F0FC00000000007FF0FC00000000007FF0FC00000000007FE0FE00000000007FE0FE0000
+0000007FE0FF0000000000FFC0FF0000000000FFC0FF8000000000FFC0FFC000000001FF
+80FFE000000001FF00FFF000000003FF00FFFC00000007FE00FFFF0000000FFC00FFFFC0
+00001FF800FFFFF800007FF000FF1FFFC003FFE000FE0FFFFFFFFFC000FC03FFFFFFFF00
+00F8007FFFFFFC0000F0000FFFFFF00000E000007FFF0000003C5479D24B>I<00007FFF
+000000000007FFFFF0000000003FFFFFFE00000000FFFFFFFF80000001FFE00FFFC00000
+03FE0001FFF0000007FF0000FFF8000007FF80003FFC00000FFF80003FFE00000FFFC000
+1FFE00000FFFC0001FFF00000FFFC0000FFF80000FFFC0000FFF80000FFFC0000FFF8000
+07FF800007FFC00007FF800007FFC00003FF000007FFC00001FE000007FFC00000000000
+07FFC0000000000007FFC0000000000007FFC0000000000007FFC0000000000007FFC000
+0000000007FFC0000000007FFFFFC00000000FFFFFFFC0000000FFFFFFFFC0000007FFFF
+87FFC000003FFFF007FFC000007FFF8007FFC00001FFFC0007FFC00003FFF00007FFC000
+07FFE00007FFC0000FFFC00007FFC0001FFF800007FFC0003FFF000007FFC0007FFF0000
+07FFC0007FFE000007FFC0007FFE000007FFC000FFFC000007FFC000FFFC000007FFC000
+FFFC000007FFC000FFFC000007FFC000FFFC00000FFFC000FFFC00000FFFC000FFFE0000
+1FFFC0007FFE00001DFFC0007FFE00003DFFC0003FFF000079FFE0001FFF8000F1FFF800
+0FFFC003E1FFFFE007FFF81FC0FFFFF003FFFFFF807FFFF000FFFFFF001FFFF0001FFFFC
+0007FFE00001FFE0000000003C387CB641>97 D<003FF0000000000000FFFFF000000000
+0000FFFFF0000000000000FFFFF0000000000000FFFFF0000000000000FFFFF000000000
+000003FFF000000000000000FFF000000000000000FFF000000000000000FFF000000000
+000000FFF000000000000000FFF000000000000000FFF000000000000000FFF000000000
+000000FFF000000000000000FFF000000000000000FFF000000000000000FFF000000000
+000000FFF000000000000000FFF000000000000000FFF000000000000000FFF000000000
+000000FFF000000000000000FFF000000000000000FFF000000000000000FFF000000000
+000000FFF000000000000000FFF000000000000000FFF000000000000000FFF001FFE000
+000000FFF00FFFFE00000000FFF03FFFFFC0000000FFF0FFFFFFF0000000FFF3FF01FFF8
+000000FFF7F8003FFE000000FFFFE0000FFF000000FFFF800007FF800000FFFF000003FF
+C00000FFFE000001FFE00000FFFC000001FFF00000FFF8000000FFF80000FFF8000000FF
+F80000FFF80000007FFC0000FFF80000007FFC0000FFF80000007FFE0000FFF80000007F
+FE0000FFF80000007FFF0000FFF80000003FFF0000FFF80000003FFF0000FFF80000003F
+FF0000FFF80000003FFF8000FFF80000003FFF8000FFF80000003FFF8000FFF80000003F
+FF8000FFF80000003FFF8000FFF80000003FFF8000FFF80000003FFF8000FFF80000003F
+FF8000FFF80000003FFF8000FFF80000003FFF8000FFF80000003FFF8000FFF80000003F
+FF8000FFF80000003FFF0000FFF80000003FFF0000FFF80000003FFF0000FFF80000003F
+FF0000FFF80000007FFE0000FFF80000007FFE0000FFF80000007FFE0000FFF80000007F
+FC0000FFF8000000FFFC0000FFF8000000FFF80000FFFC000001FFF00000FFFC000001FF
+F00000FFFE000003FFE00000FFFF000007FFC00000FFFF80000FFF800000FFCFC0001FFF
+000000FF87F0007FFC000000FF03FE03FFF8000000FE00FFFFFFE0000000FC007FFFFF80
+000000F8001FFFFC00000000000003FFC000000041547BD24B>I<000001FFF800000000
+1FFFFF80000000FFFFFFF0000003FFFFFFFC00000FFFC00FFE00001FFE0001FF00007FFC
+0003FF8000FFF00007FF8001FFF00007FFC003FFE0000FFFC003FFC0000FFFC007FFC000
+0FFFC00FFF80000FFFC00FFF80000FFFC01FFF800007FF801FFF000007FF803FFF000003
+FF003FFF000001FE007FFF00000000007FFE00000000007FFE00000000007FFE00000000
+00FFFE0000000000FFFE0000000000FFFE0000000000FFFE0000000000FFFE0000000000
+FFFE0000000000FFFE0000000000FFFE0000000000FFFE0000000000FFFE0000000000FF
+FE0000000000FFFE0000000000FFFE00000000007FFE00000000007FFF00000000007FFF
+00000000003FFF00000000003FFF00000000003FFF00000003E01FFF80000003E01FFF80
+000007E00FFFC0000007C007FFC0000007C007FFE000000FC003FFE000001F8001FFF000
+003F0000FFF800007E00007FFE0000FC00003FFF0003F800000FFFE01FF0000003FFFFFF
+E0000000FFFFFF800000003FFFFE0000000001FFE0000033387CB63C>I<000000000001
+FF80000000000007FFFF80000000000007FFFF80000000000007FFFF80000000000007FF
+FF80000000000007FFFF800000000000001FFF8000000000000007FF8000000000000007
+FF8000000000000007FF8000000000000007FF8000000000000007FF8000000000000007
+FF8000000000000007FF8000000000000007FF8000000000000007FF8000000000000007
+FF8000000000000007FF8000000000000007FF8000000000000007FF8000000000000007
+FF8000000000000007FF8000000000000007FF8000000000000007FF8000000000000007
+FF8000000000000007FF8000000000000007FF8000000000000007FF8000000000000007
+FF8000000001FFE007FF800000001FFFFC07FF80000000FFFFFF07FF80000003FFFFFFC7
+FF8000000FFFE03FE7FF8000001FFF0007F7FF8000007FFC0001FFFF800000FFF80000FF
+FF800001FFF000003FFF800003FFE000001FFF800007FFC000001FFF800007FFC000000F
+FF80000FFF8000000FFF80001FFF8000000FFF80001FFF0000000FFF80003FFF0000000F
+FF80003FFF0000000FFF80003FFF0000000FFF80007FFE0000000FFF80007FFE0000000F
+FF80007FFE0000000FFF80007FFE0000000FFF8000FFFE0000000FFF8000FFFE0000000F
+FF8000FFFE0000000FFF8000FFFE0000000FFF8000FFFE0000000FFF8000FFFE0000000F
+FF8000FFFE0000000FFF8000FFFE0000000FFF8000FFFE0000000FFF8000FFFE0000000F
+FF8000FFFE0000000FFF8000FFFE0000000FFF80007FFE0000000FFF80007FFE0000000F
+FF80007FFE0000000FFF80003FFF0000000FFF80003FFF0000000FFF80003FFF0000000F
+FF80001FFF0000000FFF80001FFF0000000FFF80000FFF8000000FFF80000FFF8000001F
+FF800007FFC000003FFF800003FFC000003FFF800001FFE000007FFF800000FFF00001FF
+FF8000007FF80003FFFFE000003FFE000FEFFFFF80000FFFC07FCFFFFF800007FFFFFF8F
+FFFF800001FFFFFE0FFFFF8000003FFFF80FFFFF80000003FFC00FFE000041547CD24B>
+I<000003FFC0000000003FFFFC00000001FFFFFF00000007FFFFFFC000000FFF81FFE000
+003FFC007FF800007FF8003FFC0000FFF0001FFE0001FFE0000FFE0003FFC00007FF0007
+FFC00007FF800FFF800003FF800FFF800003FFC01FFF800001FFC01FFF000001FFC03FFF
+000001FFE03FFF000001FFE07FFF000000FFE07FFE000000FFE07FFE000000FFF07FFE00
+0000FFF0FFFE000000FFF0FFFE000000FFF0FFFE000000FFF0FFFE000000FFF0FFFFFFFF
+FFFFF0FFFFFFFFFFFFF0FFFFFFFFFFFFF0FFFFFFFFFFFFE0FFFE0000000000FFFE000000
+0000FFFE0000000000FFFE0000000000FFFE0000000000FFFE00000000007FFE00000000
+007FFE00000000007FFF00000000003FFF00000000003FFF00000000003FFF00000000E0
+1FFF00000001F01FFF80000003F00FFF80000003F007FFC0000007E007FFC0000007E003
+FFE000000FC001FFF000001FC000FFF800003F80007FFC0000FF00001FFE0003FE00000F
+FFC03FF8000003FFFFFFF0000000FFFFFFC00000001FFFFE0000000001FFF0000034387C
+B63D>I<00003FFF0000FF000003FFFFF007FFC0000FFFFFFC1FFFE0003FFFFFFF7FFFE0
+007FFC0FFFFF9FF000FFE001FFF83FF001FFC000FFE03FF003FF80007FF01FF007FF0000
+3FF81FE00FFF00003FFC0FC00FFF00003FFC07801FFE00001FFE00001FFE00001FFE0000
+3FFE00001FFF00003FFE00001FFF00003FFE00001FFF00003FFE00001FFF00003FFE0000
+1FFF00003FFE00001FFF00003FFE00001FFF00003FFE00001FFF00003FFE00001FFF0000
+1FFE00001FFE00001FFE00001FFE00000FFF00003FFC00000FFF00003FFC000007FF0000
+3FF8000003FF80007FF0000001FFC000FFE0000000FFE001FFC0000000FFFC0FFF800000
+01FFFFFFFF00000003EFFFFFFC00000003C3FFFFF000000007C03FFF0000000007C00000
+0000000007C00000000000000FC00000000000000FC00000000000000FC0000000000000
+0FE00000000000000FE00000000000000FF80000000000000FFE0000000000000FFFFFFF
+FF00000007FFFFFFFFF8000007FFFFFFFFFF000007FFFFFFFFFFC00003FFFFFFFFFFE000
+01FFFFFFFFFFF00000FFFFFFFFFFF800007FFFFFFFFFFC00007FFFFFFFFFFE0001FFFFFF
+FFFFFF0007FFFFFFFFFFFF000FFE000003FFFF801FF80000003FFF803FF000000007FF80
+7FE000000003FFC07FE000000001FFC0FFC000000001FFC0FFC000000000FFC0FFC00000
+0000FFC0FFC000000000FFC0FFC000000000FFC0FFC000000000FFC0FFE000000001FFC0
+7FE000000001FF807FF000000003FF803FF000000003FF001FF800000007FE000FFE0000
+001FFC0007FF8000007FF80003FFE00001FFF00001FFFE001FFFE000007FFFFFFFFF8000
+000FFFFFFFFC00000001FFFFFFE0000000000FFFFC0000003C4F7CB543>103
+D<003FF0000000000000FFFFF0000000000000FFFFF0000000000000FFFFF00000000000
+00FFFFF0000000000000FFFFF000000000000003FFF000000000000000FFF00000000000
+0000FFF000000000000000FFF000000000000000FFF000000000000000FFF00000000000
+0000FFF000000000000000FFF000000000000000FFF000000000000000FFF00000000000
+0000FFF000000000000000FFF000000000000000FFF000000000000000FFF00000000000
+0000FFF000000000000000FFF000000000000000FFF000000000000000FFF00000000000
+0000FFF000000000000000FFF000000000000000FFF000000000000000FFF00000000000
+0000FFF000000000000000FFF0001FFC00000000FFF000FFFFC0000000FFF003FFFFF000
+0000FFF00FFFFFF8000000FFF01FE07FFC000000FFF03F001FFE000000FFF07C001FFF00
+0000FFF0F0000FFF000000FFF1E0000FFF800000FFF3C0000FFF800000FFF7800007FF80
+0000FFF7800007FFC00000FFFF000007FFC00000FFFE000007FFC00000FFFE000007FFC0
+0000FFFC000007FFC00000FFFC000007FFC00000FFFC000007FFC00000FFFC000007FFC0
+0000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC0
+0000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC0
+0000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC0
+0000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC0
+0000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC0
+0000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC0
+0000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC0
+0000FFF8000007FFC00000FFF8000007FFC000FFFFFFF807FFFFFFC0FFFFFFF807FFFFFF
+C0FFFFFFF807FFFFFFC0FFFFFFF807FFFFFFC0FFFFFFF807FFFFFFC042537BD24B>I<00
+7F000000FF800003FFE00007FFF00007FFF0000FFFF8000FFFF8000FFFF8000FFFF8000F
+FFF8000FFFF8000FFFF80007FFF00007FFF00003FFE00000FF8000007F00000000000000
+000000000000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000003FF000FFFFF000FFFFF000FFFFF000FFFFF000FFFFF00001
+FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000
+FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000
+FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000
+FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000
+FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF000FFFFFFE0FFFFFFE0FF
+FFFFE0FFFFFFE0FFFFFFE01B547BD325>I<003FF000FFFFF000FFFFF000FFFFF000FFFF
+F000FFFFF00001FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FF
+F00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FF
+F00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FF
+F00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FF
+F00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FF
+F00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FF
+F00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FF
+F00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FFF00000FF
+F00000FFF000FFFFFFF0FFFFFFF0FFFFFFF0FFFFFFF0FFFFFFF01C537BD225>108
+D<003FF0001FFC000000FFFFF000FFFFC00000FFFFF003FFFFF00000FFFFF00FFFFFF800
+00FFFFF01FE07FFC0000FFFFF03F001FFE000003FFF07C001FFF000000FFF0F0000FFF00
+0000FFF1E0000FFF800000FFF3C0000FFF800000FFF7800007FF800000FFF7800007FFC0
+0000FFFF000007FFC00000FFFE000007FFC00000FFFE000007FFC00000FFFC000007FFC0
+0000FFFC000007FFC00000FFFC000007FFC00000FFFC000007FFC00000FFF8000007FFC0
+0000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC0
+0000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC0
+0000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC0
+0000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC0
+0000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC0
+0000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC0
+0000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC00000FFF8000007FFC0
+0000FFF8000007FFC000FFFFFFF807FFFFFFC0FFFFFFF807FFFFFFC0FFFFFFF807FFFFFF
+C0FFFFFFF807FFFFFFC0FFFFFFF807FFFFFFC042367BB54B>110
+D<000001FFE000000000001FFFFE0000000000FFFFFFC000000003FFFFFFF00000000FFF
+807FFC0000001FFC000FFE0000007FF80007FF800000FFF00003FFC00001FFE00001FFE0
+0003FFC00000FFF00003FF8000007FF00007FF8000007FF8000FFF0000003FFC000FFF00
+00003FFC001FFF0000003FFE001FFF0000003FFE003FFE0000001FFF003FFE0000001FFF
+003FFE0000001FFF007FFE0000001FFF807FFE0000001FFF807FFE0000001FFF807FFE00
+00001FFF80FFFE0000001FFFC0FFFE0000001FFFC0FFFE0000001FFFC0FFFE0000001FFF
+C0FFFE0000001FFFC0FFFE0000001FFFC0FFFE0000001FFFC0FFFE0000001FFFC0FFFE00
+00001FFFC0FFFE0000001FFFC0FFFE0000001FFFC0FFFE0000001FFFC07FFE0000001FFF
+807FFE0000001FFF807FFE0000001FFF803FFE0000001FFF003FFF0000003FFF003FFF00
+00003FFF001FFF0000003FFE001FFF0000003FFE000FFF0000003FFC000FFF8000007FFC
+0007FF8000007FF80003FFC00000FFF00001FFE00001FFE00000FFF00003FFC000007FF8
+0007FF8000003FFE001FFF0000000FFF807FFC00000007FFFFFFF800000000FFFFFFC000
+0000003FFFFF000000000001FFE00000003A387CB643>I<003FF001FFE0000000FFFFF0
+0FFFFE000000FFFFF03FFFFFC00000FFFFF0FFFFFFF00000FFFFF3FF01FFF80000FFFFF7
+F8007FFE000003FFFFE0001FFF000000FFFF80000FFF800000FFFF000007FFC00000FFFE
+000007FFE00000FFFC000003FFF00000FFF8000001FFF80000FFF8000001FFF80000FFF8
+000000FFFC0000FFF8000000FFFC0000FFF8000000FFFE0000FFF80000007FFE0000FFF8
+0000007FFF0000FFF80000007FFF0000FFF80000007FFF0000FFF80000007FFF0000FFF8
+0000003FFF8000FFF80000003FFF8000FFF80000003FFF8000FFF80000003FFF8000FFF8
+0000003FFF8000FFF80000003FFF8000FFF80000003FFF8000FFF80000003FFF8000FFF8
+0000003FFF8000FFF80000003FFF8000FFF80000003FFF8000FFF80000003FFF8000FFF8
+0000003FFF0000FFF80000007FFF0000FFF80000007FFF0000FFF80000007FFF0000FFF8
+0000007FFE0000FFF8000000FFFE0000FFF8000000FFFE0000FFF8000000FFFC0000FFF8
+000001FFFC0000FFF8000001FFF80000FFFC000003FFF00000FFFC000003FFF00000FFFE
+000007FFE00000FFFF00000FFFC00000FFFF80001FFF800000FFFFC0003FFF000000FFFF
+F000FFFC000000FFFBFE07FFF8000000FFF8FFFFFFE0000000FFF87FFFFF80000000FFF8
+1FFFFC00000000FFF803FFC000000000FFF800000000000000FFF800000000000000FFF8
+00000000000000FFF800000000000000FFF800000000000000FFF800000000000000FFF8
+00000000000000FFF800000000000000FFF800000000000000FFF800000000000000FFF8
+00000000000000FFF800000000000000FFF800000000000000FFF800000000000000FFF8
+00000000000000FFF800000000000000FFF8000000000000FFFFFFF80000000000FFFFFF
+F80000000000FFFFFFF80000000000FFFFFFF80000000000FFFFFFF80000000000414D7B
+B54B>I<007FE003FE00FFFFE00FFF80FFFFE03FFFE0FFFFE07FFFF0FFFFE0FE1FF8FFFF
+E1F83FFC03FFE3E03FFE00FFE3C07FFE00FFE7807FFE00FFEF807FFE00FFEF007FFE00FF
+EE007FFE00FFFE003FFC00FFFC003FFC00FFFC001FF800FFFC000FF000FFF800000000FF
+F800000000FFF800000000FFF800000000FFF800000000FFF000000000FFF000000000FF
+F000000000FFF000000000FFF000000000FFF000000000FFF000000000FFF000000000FF
+F000000000FFF000000000FFF000000000FFF000000000FFF000000000FFF000000000FF
+F000000000FFF000000000FFF000000000FFF000000000FFF000000000FFF000000000FF
+F000000000FFF000000000FFF000000000FFF000000000FFF000000000FFF000000000FF
+F000000000FFF0000000FFFFFFFC0000FFFFFFFC0000FFFFFFFC0000FFFFFFFC0000FFFF
+FFFC00002F367CB537>114 D<0003FFF00F00003FFFFE1F0000FFFFFFFF0003FFFFFFFF
+0007FF003FFF000FF80007FF001FE00001FF003FC00000FF003F8000007F007F8000007F
+007F0000003F007F0000003F00FF0000001F00FF0000001F00FF8000001F00FF8000001F
+00FFC000001F00FFF000000000FFFC00000000FFFFC00000007FFFFF0000007FFFFFF800
+003FFFFFFF00003FFFFFFFC0001FFFFFFFF0000FFFFFFFF80007FFFFFFFC0003FFFFFFFE
+0000FFFFFFFF00003FFFFFFF80000FFFFFFFC00000FFFFFFC0000007FFFFE00000003FFF
+E000000007FFF000000001FFF0780000007FF0F80000003FF0F80000001FF0FC0000001F
+F0FC0000000FF0FC0000000FF0FE0000000FF0FE0000000FE0FF0000000FE0FF8000001F
+E0FF8000001FC0FFC000001FC0FFE000003F80FFF800007F00FFFE0001FE00FFFFC00FFC
+00FF7FFFFFF800FC1FFFFFE000F807FFFF8000F000FFF800002C387CB635>I<00003E00
+000000003E00000000003E00000000003E00000000003E00000000003E00000000007E00
+000000007E00000000007E00000000007E0000000000FE0000000000FE0000000001FE00
+00000001FE0000000001FE0000000003FE0000000007FE0000000007FE000000000FFE00
+0000001FFE000000003FFE00000000FFFE00000001FFFE0000000FFFFFFFFF00FFFFFFFF
+FF00FFFFFFFFFF00FFFFFFFFFF00FFFFFFFFFF00003FFE000000003FFE000000003FFE00
+0000003FFE000000003FFE000000003FFE000000003FFE000000003FFE000000003FFE00
+0000003FFE000000003FFE000000003FFE000000003FFE000000003FFE000000003FFE00
+0000003FFE000000003FFE000000003FFE000000003FFE000000003FFE000000003FFE00
+0000003FFE000000003FFE000000003FFE000000003FFE000000003FFE000000003FFE00
+0000003FFE0007C0003FFE0007C0003FFE0007C0003FFE0007C0003FFE0007C0003FFE00
+07C0003FFE0007C0003FFE0007C0003FFE0007C0003FFE0007C0003FFE0007C0001FFE00
+0F80001FFF000F80001FFF000F80000FFF001F00000FFF801F000007FFC03E000003FFF0
+FC000001FFFFF80000007FFFF00000001FFFE000000003FF80002A4D7ECB34>I<FFFFFF
+E07FFFFFC003FFFFC0FFFFFFE07FFFFFC003FFFFC0FFFFFFE07FFFFFC003FFFFC0FFFFFF
+E07FFFFFC003FFFFC0FFFFFFE07FFFFFC003FFFFC001FFF00000FFF000001FF80001FFF8
+00007FF0000007E00000FFF800007FF8000007C00000FFF800007FF8000007C00000FFFC
+00003FF800000FC000007FFC00003FFC00000F8000007FFC00003FFC00000F8000007FFE
+00003FFC00001F8000003FFE00007FFE00001F0000003FFF00007FFE00003F0000001FFF
+00007FFF00003E0000001FFF0000FFFF00003E0000001FFF8000FFFF00007E0000000FFF
+8001FFFF80007C0000000FFFC001F3FF8000FC00000007FFC001F3FFC000F800000007FF
+C003F3FFC000F800000007FFE003E1FFC001F800000003FFE007E1FFE001F000000003FF
+F007C0FFE001F000000001FFF007C0FFF003E000000001FFF00FC0FFF003E000000001FF
+F80F807FF007E000000000FFF80F807FF807C000000000FFF81F003FF807C000000000FF
+FC1F003FF80FC0000000007FFC3F003FFC0F80000000007FFE3E001FFC1F80000000003F
+FE3E001FFE1F00000000003FFE7E001FFE1F00000000003FFF7C000FFE3F00000000001F
+FFFC000FFF3E00000000001FFFF80007FF7E00000000000FFFF80007FFFC00000000000F
+FFF80007FFFC00000000000FFFF00003FFFC000000000007FFF00003FFF8000000000007
+FFE00001FFF8000000000003FFE00001FFF0000000000003FFE00001FFF0000000000003
+FFC00000FFF0000000000001FFC00000FFE0000000000001FF8000007FE0000000000001
+FF8000007FE0000000000000FF8000007FC0000000000000FF0000003FC0000000000000
+7F0000003F800000000000007F0000003F800000000000003E0000001F000000005A367D
+B461>119 D<FFFFFFF00007FFFFFFFFFFF00007FFFFFFFFFFF00007FFFFFFFFFFF00007
+FFFFFFFFFFF00007FFFF00FFF80000007FE000FFFC0000003F0000FFFC0000003F00007F
+FE0000003E00007FFE0000007E00003FFE0000007C00003FFF000000FC00001FFF000000
+F800001FFF800001F800000FFF800001F000000FFFC00003F0000007FFC00003E0000007
+FFE00003E0000007FFE00007E0000003FFF00007C0000003FFF0000FC0000001FFF8000F
+80000001FFF8001F80000000FFF8001F00000000FFFC003F000000007FFC003E00000000
+7FFE007E000000003FFE007C000000003FFF00FC000000003FFF00FC000000001FFF80F8
+000000001FFF81F8000000000FFFC1F0000000000FFFC3F00000000007FFC3E000000000
+07FFE7E00000000003FFE7C00000000003FFFFC00000000001FFFF800000000001FFFF80
+0000000000FFFF000000000000FFFF000000000000FFFF0000000000007FFE0000000000
+007FFE0000000000003FFC0000000000003FFC0000000000001FF80000000000001FF800
+00000000000FF00000000000000FF000000000000007E000000000000007E00000000000
+0007E000000000000007C00000000000000FC00000000000000F800000000000001F8000
+00000000001F000000000000003F000000001FC0003E000000003FE0007E000000007FF0
+007C00000000FFF800FC00000000FFF800F800000000FFF801F800000000FFF801F00000
+0000FFF803F000000000FFF807E0000000007FF00FC0000000007FE01F80000000003FC0
+7F00000000003F81FE00000000001FFFFC00000000000FFFF0000000000003FFE0000000
+000000FF000000000000404D7DB447>121 D E /Fh 20 120 df<3C007E00FF00FF00FF
+80FF807F803D800180018001800180038003000300070006000E000C001C003800700060
+0009177AB315>39 D<3C7EFFFFFFFF7E3C08087A8715>46 D<000001C000000001C00000
+0003C000000007C000000007C00000000FC00000001FC00000001FC00000003FC0000000
+7FC00000006FC0000000CFC0000001CFC00000038FC00000030FC00000070FC000000E0F
+C000000C0FC000001C0FC00000380FC00000300FC00000700FC00000E00FC00000C00FC0
+0001800FC00003800FC00003000FC00006000FC0000E000FC0000C000FC00018000FC000
+38000FC00030000FC00060000FC000E0000FC000FFFFFFFF80FFFFFFFF80FFFFFFFF8000
+000FC00000000FC00000000FC00000000FC00000000FC00000000FC00000000FC0000000
+0FC00000000FC00000001FE0000007FFFF800007FFFF800007FFFF8021337EB226>52
+D<000FE000007FFC0000FFFF0003F01F8007C007C00F0003E00E0001F01E0000F01C0000
+F83C0000783C0000783C0000783E0000783E0000783F0000F83F8000F03FC001F01FF001
+E01FF803C00FFE078007FF0F0003FFDE0001FFF80000FFF800003FFE00003FFF0000F7FF
+C003E3FFE00780FFF00F007FF81E001FF83E0007FC3C0003FC780001FC7800007EF80000
+7EF000003EF000003EF000001EF000001EF000001EF800001EF800003C7800003C7C0000
+783E0000781F0000F00F8003E007F01FC001FFFF00007FFC00001FE0001F347DB126>56
+D<001FE00300007FFC070001FFFF070007F01FCF000F8003FF001F0000FF003E00007F00
+3E00003F007C00001F007C00001F007800000F00F800000700F800000700F800000700F8
+00000700FC00000300FC00000300FE00000300FE000000007F000000007FC00000003FF0
+0000003FFF0000001FFFF000000FFFFF000007FFFFC00003FFFFF00000FFFFF800003FFF
+FC000003FFFE0000003FFF00000003FF00000000FF800000007F800000003F800000001F
+C00000000FC0C000000FC0C000000FC0C0000007C0C0000007C0C0000007C0E0000007C0
+E0000007C0F000000F80F000000F80F800000F00FC00001F00FE00003E00FF00007E00FF
+C000FC00F1FC03F800E0FFFFE000E01FFF8000C003FE000022377CB42B>83
+D<007F80000003FFF000000F80FC00001C003E00003F003F00003F801F80003F800FC000
+3F800FC0003F8007E0001F0007E000000007E000000007E000000007E000000007E00000
+01FFE000001FFFE00000FF87E00003FC07E0000FF007E0001FC007E0003F8007E0007F80
+07E0007F0007E000FF0007E0C0FE0007E0C0FE0007E0C0FE0007E0C0FE000FE0C0FE000F
+E0C0FF001FE0C07F003BE0C03F8071F1801FC1E1FF8007FFC0FF0000FE003C0022237DA1
+26>97 D<0007F800003FFF0000FC07C001F000E003E003F007C007F00FC007F01F8007F0
+3F8007F03F0003E07F0000007F0000007E000000FE000000FE000000FE000000FE000000
+FE000000FE000000FE000000FE000000FE000000FE0000007F0000007F0000003F000018
+3F8000181F8000381FC000300FC0007007E000E003F001C000FC0F80003FFE000007F000
+1D237EA122>99 D<0000003F0000000FFF0000000FFF0000000FFF000000007F00000000
+3F000000003F000000003F000000003F000000003F000000003F000000003F000000003F
+000000003F000000003F000000003F000000003F000000003F000000003F000007F03F00
+003FFC3F0000FC0F3F0001F003BF0007E001FF000FC000FF001F80007F001F80003F003F
+00003F003F00003F007F00003F007E00003F00FE00003F00FE00003F00FE00003F00FE00
+003F00FE00003F00FE00003F00FE00003F00FE00003F00FE00003F00FE00003F007E0000
+3F007F00003F007F00003F003F00003F001F80007F001F80007F000FC000FF0007E001FF
+8003F007BFFC00F81E3FFC003FFC3FFC000FE03F0026357DB32B>I<000FE000007FFC00
+00F83F0003F00F8007E00FC00FC007E01F8003E01F8003F03F0003F03F0001F07F0001F8
+7E0001F87E0001F8FE0001F8FE0001F8FFFFFFF8FFFFFFF8FE000000FE000000FE000000
+FE000000FE0000007E0000007F0000007F0000003F0000183F0000181F8000380F800030
+0FC0007007E000E001F003C000FC0F00003FFE000007F0001D237EA122>I<0001FC0000
+07FF00001F0780003E0FC0007C1FC000FC1FC001F81FC001F81FC003F8070003F0000003
+F0000003F0000003F0000003F0000003F0000003F0000003F0000003F0000003F0000003
+F0000003F00000FFFFF000FFFFF000FFFFF00003F0000003F0000003F0000003F0000003
+F0000003F0000003F0000003F0000003F0000003F0000003F0000003F0000003F0000003
+F0000003F0000003F0000003F0000003F0000003F0000003F0000003F0000003F0000003
+F0000003F0000003F0000007F800007FFFE0007FFFE0007FFFE0001A357FB417>I<03F0
+000000FFF0000000FFF0000000FFF000000007F000000003F000000003F000000003F000
+000003F000000003F000000003F000000003F000000003F000000003F000000003F00000
+0003F000000003F000000003F000000003F000000003F01FC00003F07FF00003F1E0FC00
+03F3807C0003F7007E0003FE007E0003FC003F0003FC003F0003F8003F0003F8003F0003
+F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0
+003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F000
+3F0003F0003F0003F0003F0003F0003F0003F0003F0007F8007F80FFFFC7FFFCFFFFC7FF
+FCFFFFC7FFFC26347EB32B>104 D<07E0FFE0FFE0FFE00FE007E007E007E007E007E007
+E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007
+E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007E007
+E007E00FF0FFFFFFFFFFFF10347EB315>108 D<03F01FE000FF0000FFF07FF803FFC000
+FFF1E07C0F03E000FFF3803E1C01F00007F7003F3801F80003FE003F7001F80003FC001F
+E000FC0003FC001FE000FC0003F8001FC000FC0003F8001FC000FC0003F0001F8000FC00
+03F0001F8000FC0003F0001F8000FC0003F0001F8000FC0003F0001F8000FC0003F0001F
+8000FC0003F0001F8000FC0003F0001F8000FC0003F0001F8000FC0003F0001F8000FC00
+03F0001F8000FC0003F0001F8000FC0003F0001F8000FC0003F0001F8000FC0003F0001F
+8000FC0003F0001F8000FC0003F0001F8000FC0003F0001F8000FC0003F0001F8000FC00
+07F8003FC001FE00FFFFC7FFFE3FFFF0FFFFC7FFFE3FFFF0FFFFC7FFFE3FFFF03C217EA0
+41>I<03F01FC000FFF07FF000FFF1E0FC00FFF3807C0007F7007E0003FE007E0003FC00
+3F0003FC003F0003F8003F0003F8003F0003F0003F0003F0003F0003F0003F0003F0003F
+0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F00
+03F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003
+F0003F0007F8007F80FFFFC7FFFCFFFFC7FFFCFFFFC7FFFC26217EA02B>I<0007F00000
+003FFE000000FC1F800001F007C00003C001E00007C001F0000F8000F8001F00007C001F
+00007C003F00007E003E00003E007E00003F007E00003F007E00003F00FE00003F80FE00
+003F80FE00003F80FE00003F80FE00003F80FE00003F80FE00003F80FE00003F807E0000
+3F007E00003F007E00003F003F00007E003F00007E001F00007C001F8000FC000FC001F8
+0007C001F00003F007E00000FC1F8000003FFE00000007F0000021237EA126>I<03E07C
+00FFE1FF00FFE38F80FFE71FC007EE1FC003EC1FC003EC1FC003FC0F8003F8000003F800
+0003F8000003F0000003F0000003F0000003F0000003F0000003F0000003F0000003F000
+0003F0000003F0000003F0000003F0000003F0000003F0000003F0000003F0000003F000
+0003F0000007F80000FFFFE000FFFFE000FFFFE0001A217FA01E>114
+D<00FF060007FFCE001F00FE003C003E0078001E0078000E00F0000E00F0000600F00006
+00F8000600F8000600FE000000FF8000007FFC00003FFFC0003FFFF0000FFFF80007FFFC
+0000FFFE00000FFF000000FF0000003F80C0001F80C0000F80E0000780E0000780E00007
+80F0000780F0000700F8000F00FC000E00FE001C00F7807800E1FFE000C07F800019237E
+A11E>I<00300000300000300000300000300000700000700000700000F00000F00001F0
+0001F00003F00007F0001FFFFEFFFFFEFFFFFE03F00003F00003F00003F00003F00003F0
+0003F00003F00003F00003F00003F00003F00003F00003F00003F00003F00303F00303F0
+0303F00303F00303F00303F00303F00303F00701F80601F80600FC0E007E1C001FF80007
+E0182F7FAD1E>I<03F0003F00FFF00FFF00FFF00FFF00FFF00FFF0007F0007F0003F000
+3F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F
+0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F0003F00
+03F0003F0003F0003F0003F0003F0003F0003F0003F0007F0003F0007F0003F0007F0003
+F000FF0001F000FF0001F801FF8000F803BFFC007E073FFC001FFE3FFC0007F83F002622
+7EA02B>I<FFFF1FFF81FFF0FFFF1FFF81FFF0FFFF1FFF81FFF007F801FC003F8007F001
+F8001E0003F000F8001C0003F000FC001C0001F8007C00180001F8007C00180001FC007E
+00380000FC00FE00300000FC00FE003000007E01FF006000007E019F006000007E019F80
+6000003F030F80C000003F030F80C000003F030FC0C000001F8607C18000001F8607C180
+00001FC607E38000000FCC03E30000000FCC03E300000007FC03F600000007F801F60000
+0007F801FE00000003F000FC00000003F000FC00000003F000FC00000001E00078000000
+01E0007800000001E0007800000000C00030000034217F9F37>119
+D E /Fi 7 117 df<0000001F800000000000001F800000000000003FC0000000000000
+3FC00000000000007FE00000000000007FE00000000000007FE0000000000000FFF00000
+00000000FFF0000000000001FFF8000000000001FFF8000000000001FFF8000000000003
+FFFC000000000003FFFC000000000007FFFE000000000007CFFE000000000007CFFE0000
+0000000FCFFF00000000000F87FF00000000001F87FF80000000001F03FF80000000003F
+03FFC0000000003E01FFC0000000003E01FFC0000000007E01FFE0000000007C00FFE000
+000000FC00FFF000000000F8007FF000000000F8007FF000000001F8007FF800000001F0
+003FF800000003F0003FFC00000003E0001FFC00000003E0001FFC00000007FFFFFFFE00
+000007FFFFFFFE0000000FFFFFFFFF0000000FFFFFFFFF0000001F800007FF8000001F00
+0003FF8000001F000003FF8000003F000003FFC000003E000001FFC000007E000001FFE0
+00007C000000FFE000007C000000FFE00000FC000000FFF00000F80000007FF000FFFFF0
+003FFFFFF0FFFFF0003FFFFFF0FFFFF0003FFFFFF0FFFFF0003FFFFFF03C347DB343>65
+D<007FFE000003FFFFE00007FFFFF8000FF00FFC001FF803FF001FF801FF001FF800FF80
+1FF800FFC01FF8007FC00FF0007FC007E0007FC00180007FC00000007FC000007FFFC000
+0FFFFFC000FFFFFFC003FFF07FC00FFF007FC01FF8007FC03FF0007FC07FE0007FC0FFC0
+007FC0FF80007FC0FF80007FC0FF80007FC0FF8000FFC0FFC000FFC07FC001FFC07FE003
+FFE03FF80FBFFF0FFFFF1FFF03FFFC0FFF007FE007FF28217EA02B>97
+D<01FC00000000FFFC00000000FFFC00000000FFFC00000000FFFC000000000FFC000000
+0007FC0000000007FC0000000007FC0000000007FC0000000007FC0000000007FC000000
+0007FC0000000007FC0000000007FC0000000007FC0000000007FC0000000007FC000000
+0007FC0000000007FC07FC000007FC7FFF800007FDFFFFE00007FFF00FF80007FFC007FC
+0007FF0003FE0007FE0001FF0007FC0000FF8007FC0000FF8007FC0000FFC007FC00007F
+C007FC00007FC007FC00007FE007FC00007FE007FC00007FE007FC00007FE007FC00007F
+E007FC00007FE007FC00007FE007FC00007FE007FC00007FE007FC00007FC007FC00007F
+C007FC0000FFC007FC0000FF8007FC0000FF8007FE0001FF0007FF0003FE0007FFC007FC
+0007F3F01FF80007E1FFFFE00007C07FFF800007800FF800002B347EB331>I<0007FF80
+00003FFFF00000FFFFFC0003FE01FE0007FC03FF000FF803FF001FF003FF003FE003FF00
+3FE003FF007FE001FE007FC000FC007FC0003000FFC0000000FFC0000000FFC0000000FF
+C0000000FFC0000000FFC0000000FFC0000000FFC0000000FFC00000007FC00000007FE0
+0000007FE00000003FE00007803FF00007801FF8000F800FF8001F0007FE003E0003FF80
+FC0000FFFFF800003FFFE0000007FF000021217DA027>I<01F81F80FFF87FF0FFF8FFF8
+FFF9E3FCFFFBC7FE0FFF87FE07FF07FE07FF07FE07FE07FE07FE03FC07FE01F807FE0060
+07FC000007FC000007FC000007FC000007FC000007FC000007FC000007FC000007FC0000
+07FC000007FC000007FC000007FC000007FC000007FC000007FC000007FC0000FFFFF000
+FFFFF000FFFFF000FFFFF0001F217EA024>114 D<00FFE1C007FFFFC00FFFFFC03F803F
+C07E000FC07E0007C0FC0007C0FC0003C0FE0003C0FE0003C0FF800000FFFC0000FFFFE0
+007FFFFC007FFFFE003FFFFF800FFFFFC007FFFFE000FFFFE0000FFFF000007FF000000F
+F0F00007F0F00003F0F80003F0F80003F0FC0003E0FE0007E0FF000FC0FFC01F80FFFFFF
+00F9FFFC00E03FE0001C217DA023>I<003C0000003C0000003C0000003C0000003C0000
+007C0000007C0000007C000000FC000000FC000001FC000001FC000003FC000007FC0000
+1FFFFF80FFFFFF80FFFFFF80FFFFFF8007FC000007FC000007FC000007FC000007FC0000
+07FC000007FC000007FC000007FC000007FC000007FC000007FC000007FC000007FC0000
+07FC000007FC000007FC03C007FC03C007FC03C007FC03C007FC03C007FC03C007FC03C0
+07FE078003FE078001FF0F0000FFFE00003FFC00000FF0001A2F7EAE22>I
+E /Fj 14 122 df<1E007F807F80FFC0FFC0FFC0FFC07F807F801E000A0A78891B>46
+D<00000000C00000000000000001E00000000000000001E00000000000000001E0000000
+0000000003F00000000000000003F00000000000000003F00000000000000007F8000000
+0000000007F80000000000000007F8000000000000000FFC000000000000000FFC000000
+000000000FFC0000000000000019FE0000000000000019FE0000000000000019FE000000
+0000000030FF0000000000000030FF0000000000000070FF80000000000000607F800000
+00000000607F80000000000000E07FC0000000000000C03FC0000000000000C03FC00000
+00000001C03FE0000000000001801FE0000000000001801FE0000000000003001FF00000
+00000003000FF0000000000003000FF0000000000006000FF80000000000060007F80000
+000000060007F800000000000C0003FC00000000000C0003FC00000000000C0003FC0000
+000000180001FE0000000000180001FE0000000000180001FE0000000000300000FF0000
+000000300000FF0000000000700000FF80000000006000007F80000000006000007F8000
+000000E000007FC000000000FFFFFFFFC000000000FFFFFFFFC000000001FFFFFFFFE000
+0000018000001FE0000000018000001FE0000000030000001FF0000000030000000FF000
+0000030000000FF0000000060000000FF80000000600000007F80000000600000007F800
+00000C00000003FC0000000C00000003FC0000000C00000003FC0000001800000001FE00
+00001800000001FE0000001800000001FE0000003000000000FF0000003000000000FF00
+00007800000000FF800000F800000000FF800001FC00000000FFC0000FFF00000003FFE0
+00FFFFE000007FFFFFC0FFFFE000007FFFFFC0FFFFE000007FFFFFC042477DC649>65
+D<FFFFFFC00001FFFFC0FFFFFFC00001FFFFC0FFFFFFC00001FFFFC001FFE00000007FFC
+0000FFC00000003FE000007F800000003F8000007F800000003E0000007F800000003C00
+00007F80000000380000007F80000000700000007F80000000E00000007F80000001C000
+00007F80000003800000007F80000007000000007F8000001E000000007F800000380000
+00007F80000070000000007F800000E0000000007F800001C0000000007F800003800000
+00007F80000700000000007F80000E00000000007F80001C00000000007F800038000000
+00007F80007000000000007F8000E000000000007F8001C000000000007F8003E0000000
+00007F8007F000000000007F800FF000000000007F801FF800000000007F803FFC000000
+00007F8077FC00000000007F80E3FE00000000007F81C1FF00000000007F8381FF000000
+00007F8700FF80000000007F8E007FC0000000007F9C007FC0000000007FB8003FE00000
+00007FF0001FF0000000007FC0001FF0000000007F80000FF8000000007F800007FC0000
+00007F800007FC000000007F800003FE000000007F800001FF000000007F800001FF0000
+00007F800000FF800000007F8000007FC00000007F8000007FC00000007F8000003FE000
+00007F8000001FF00000007F8000001FF00000007F8000000FF80000007F80000007FC00
+00007F80000007FC0000007F80000003FE0000007F80000001FF0000007F80000001FF00
+00007F80000000FF8000007F80000000FFC000007F80000000FFE00000FFC0000000FFF0
+0001FFE0000001FFFC00FFFFFFC0001FFFFFE0FFFFFFC0001FFFFFE0FFFFFFC0001FFFFF
+E043447CC34C>75 D<FFFFFFFFE000000000FFFFFFFFFF00000000FFFFFFFFFFC0000000
+01FFC0003FF8000000007F800003FC000000007F800000FF000000007F8000007F800000
+007F8000003FC00000007F8000001FE00000007F8000000FF00000007F80000007F80000
+007F80000007F80000007F80000007FC0000007F80000003FC0000007F80000003FE0000
+007F80000003FE0000007F80000003FE0000007F80000003FE0000007F80000003FE0000
+007F80000003FE0000007F80000003FE0000007F80000003FC0000007F80000003FC0000
+007F80000007FC0000007F80000007F80000007F8000000FF00000007F8000000FF00000
+007F8000001FE00000007F8000003FC00000007F8000007F000000007F800001FE000000
+007F800007F8000000007F80003FE0000000007FFFFFFF00000000007FFFFFFC00000000
+007F80007F80000000007F80000FE0000000007F800007F0000000007F800003FC000000
+007F800001FE000000007F800000FE000000007F800000FF000000007F8000007F800000
+007F8000007F800000007F8000003FC00000007F8000003FC00000007F8000003FC00000
+007F8000003FC00000007F8000003FC00000007F8000003FC00000007F8000003FC00000
+007F8000003FE00000007F8000003FE00000007F8000003FE00000007F8000003FE00000
+007F8000003FE00000007F8000003FE00000007F8000003FE00000007F8000003FE00060
+007F8000003FF00060007F8000001FF00060007F8000001FF00060007F8000001FF000E0
+007F8000000FF800C001FFE0000007F801C0FFFFFFC00007F80180FFFFFFC00001FC0380
+FFFFFFC00000FE07000000000000003FFE0000000000000007F80043467CC348>82
+D<0007FC000000003FFF80000000F80FE0000003C003F00000070001F800000E0000FC00
+000FC0007E00001FE0007F00001FF0003F80001FF0003F80001FF0003F80001FF0001FC0
+001FF0001FC0000FE0001FC0000380001FC0000000001FC0000000001FC0000000001FC0
+000000001FC00000000FFFC0000001FFFFC000000FFE1FC000003FC01FC00000FF001FC0
+0003FC001FC00007F8001FC0000FF0001FC0001FE0001FC0003FC0001FC0007FC0001FC0
+007F80001FC0007F80001FC060FF00001FC060FF00001FC060FF00001FC060FF00003FC0
+60FF00003FC060FF00003FC060FF80007FC0607F8000EFC0607FC000C7E0C03FC001C7E0
+C01FE00783F1C007F81E03FF8001FFFC01FF00001FE0007C002B2E7CAC31>97
+D<00007F80000003FFF000000FC07C00003F000F0000FC00038001F80001C003F8000FC0
+07F0001FE007E0003FE00FE0003FE01FC0003FE01FC0003FE03F80003FE03F80001FC07F
+800007007F800000007F800000007F00000000FF00000000FF00000000FF00000000FF00
+000000FF00000000FF00000000FF00000000FF00000000FF00000000FF00000000FF0000
+00007F000000007F800000007F800000003F800000003F800000303FC00000301FC00000
+700FE00000600FE00000E007F00000C003F80001C001F800038000FC000700003F001E00
+001FC078000007FFF0000000FF8000242E7DAC2B>99 D<000000007F000000003FFF0000
+00003FFF000000003FFF0000000001FF0000000000FF00000000007F00000000007F0000
+0000007F00000000007F00000000007F00000000007F00000000007F00000000007F0000
+0000007F00000000007F00000000007F00000000007F00000000007F00000000007F0000
+0000007F00000000007F00000000007F00000000007F00000000007F0000007F807F0000
+03FFF07F00000FC07C7F00003F000E7F00007E00077F0000FC0003FF0003F80001FF0007
+F00000FF0007E00000FF000FE000007F001FC000007F001FC000007F003F8000007F003F
+8000007F007F8000007F007F8000007F007F0000007F00FF0000007F00FF0000007F00FF
+0000007F00FF0000007F00FF0000007F00FF0000007F00FF0000007F00FF0000007F00FF
+0000007F00FF0000007F00FF0000007F007F0000007F007F8000007F007F8000007F003F
+8000007F003F8000007F001FC000007F001FC000007F000FC00000FF000FE00000FF0007
+F00001FF0003F00003FF0001F800077F8000FC000E7FC0003F001C7FFE000FC0F87FFE00
+03FFE07FFE00007F007F002F467DC436>I<0001FE00000007FFC000001F03F000007E00
+FC0000FC007E0001F8003F0003F0003F0007E0001F800FE0001FC00FC0000FC01FC0000F
+C03F80000FE03F800007E03F800007E07F800007F07F000007F07F000007F0FF000007F0
+FF000007F0FF000007F0FFFFFFFFF0FFFFFFFFF0FF00000000FF00000000FF00000000FF
+00000000FF00000000FF000000007F000000007F000000007F800000007F800000003F80
+0000003F800000301FC00000301FC00000700FC00000600FE00000E007F00000C003F000
+01C001F800038000FC000700003E001E00001F80F8000003FFE0000000FF0000242E7DAC
+2B>I<01FC00000000FFFC00000000FFFC00000000FFFC0000000007FC0000000003FC00
+00000001FC0000000001FC0000000001FC0000000001FC0000000001FC0000000001FC00
+00000001FC0000000001FC0000000001FC0000000001FC0000000001FC0000000001FC00
+00000001FC0000000001FC0000000001FC0000000001FC0000000001FC0000000001FC00
+00000001FC0000000001FC01FE000001FC07FFC00001FC1E07F00001FC3801F80001FC70
+01FC0001FCE000FC0001FDC000FE0001FD8000FE0001FF80007F0001FF00007F0001FF00
+007F0001FE00007F0001FE00007F0001FE00007F0001FC00007F0001FC00007F0001FC00
+007F0001FC00007F0001FC00007F0001FC00007F0001FC00007F0001FC00007F0001FC00
+007F0001FC00007F0001FC00007F0001FC00007F0001FC00007F0001FC00007F0001FC00
+007F0001FC00007F0001FC00007F0001FC00007F0001FC00007F0001FC00007F0001FC00
+007F0001FC00007F0001FC00007F0001FC00007F0001FC00007F0001FC00007F0003FE00
+00FF80FFFFF83FFFFEFFFFF83FFFFEFFFFF83FFFFE2F457DC436>104
+D<01E00007F80007F8000FFC000FFC000FFC000FFC0007F80007F80001E0000000000000
+0000000000000000000000000000000000000000000000000000000000000000000001FC
+00FFFC00FFFC00FFFC0007FC0003FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC
+0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC
+0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC
+0001FC0001FC0001FC0003FE00FFFFF8FFFFF8FFFFF815437DC21C>I<01FC00FFFC00FF
+FC00FFFC0007FC0003FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001
+FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001
+FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001
+FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001
+FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001FC0001
+FC0001FC0001FC0003FE00FFFFF8FFFFF8FFFFF815457DC41C>108
+D<03F803F0FFF81FFCFFF83C3EFFF8707F07F8E0FF03F9C0FF01F980FF01FB80FF01FB00
+7E01FB003C01FF000001FE000001FE000001FE000001FE000001FC000001FC000001FC00
+0001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC00
+0001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC000001FC00
+0001FC000001FC000001FC000001FC000003FF0000FFFFFE00FFFFFE00FFFFFE00202C7D
+AB26>114 D<003FE01801FFFC3807E01F780F0003F81E0001F83C0000F87C0000787800
+0078F8000038F8000038F8000018F8000018FC000018FC000018FE000018FF8000007FC0
+00007FFC00003FFFE0001FFFFC000FFFFF0007FFFFC003FFFFE000FFFFF0001FFFF80000
+FFF800000FFC000003FCC00001FEC00000FEC000007EE000007EE000003EE000003EF000
+003EF000003EF000003EF800003CFC00007CFC000078FE0000F8FF0001F0F38003E0F1F0
+0F80E07FFE00C00FF0001F2E7DAC26>I<FFFFF001FFFCFFFFF001FFFCFFFFF001FFFC07
+FF00007FE003FE00001F8001FE00001F0001FE00000E0000FE00000C0000FF00001C0000
+7F00001800007F00001800007F80003800003F80003000003F80003000001FC000600000
+1FC0006000001FE000E000000FE000C000000FE000C0000007F00180000007F001800000
+07F80380000003F80300000003F80300000001FC0600000001FC0600000001FE0E000000
+00FE0C00000000FE0C000000007F18000000007F18000000007FB8000000003FB0000000
+003FB0000000001FE0000000001FE0000000001FE0000000000FC0000000000FC0000000
+000780000000000780000000000780000000000300000000000300000000000600000000
+000600000000000600000000000C00000000000C0000000000180000000000180000003C
+00180000007E0030000000FF0030000000FF0060000000FF0060000000FF00C0000000FE
+01C00000007C03800000007007000000003C1E000000000FFC0000000003F0000000002E
+3F7EAA33>121 D E /Fk 15 118 df<0F003FC07FE0FFF0FFF0FFF8FFF8FFF8FFFC7FFC
+3FDC0F1C001C001C001C001C001C001C001C003C00380038003800780078007000F000F0
+00E001E003C003C0078007000F001E003C007800780030000E2874E324>39
+D<000000000078000000000000007800000000000000F800000000000001F80000000000
+0001F800000000000003F800000000000007F800000000000007F80000000000000FF800
+00000000001FF80000000000001FF80000000000003FF80000000000003FF80000000000
+007FF8000000000000FFF8000000000000EFF8000000000001EFF8000000000003CFF800
+00000000038FF80000000000078FF80000000000070FF800000000000E0FF80000000000
+1E0FF800000000001C0FF800000000003C0FF80000000000780FF80000000000700FF800
+00000000F00FF80000000000E00FF80000000001C00FF80000000003C00FF80000000003
+800FF80000000007800FF8000000000F000FF8000000000E000FF8000000001E000FF800
+0000001C000FF80000000038000FF80000000078000FF80000000070000FF800000000F0
+000FF800000001E0000FF800000001C0000FF800000003C0000FF80000000380000FF800
+00000700000FF80000000F00000FF80000000E00000FF80000001E00000FF80000003C00
+000FF80000003800000FF80000007800000FF8000000F000000FF8000000E000000FF800
+0001E000000FF8000001C000000FF8000003C000000FF80000078000000FF80000070000
+000FF800000F0000000FF800001E0000000FF800001C0000000FF800003C0000000FF800
+00380000000FF80000700000000FF80000F00000000FF80000FFFFFFFFFFFFFFE0FFFFFF
+FFFFFFFFE0FFFFFFFFFFFFFFE0FFFFFFFFFFFFFFE0000000000FF80000000000000FF800
+00000000000FF80000000000000FF80000000000000FF80000000000000FF80000000000
+000FF80000000000000FF80000000000000FF80000000000000FF80000000000000FF800
+00000000000FF80000000000000FF80000000000000FF80000000000000FF80000000000
+000FF80000000000000FF80000000000000FF80000000000000FF80000000000001FFC00
+00000000007FFF0000000001FFFFFFFFC0000001FFFFFFFFC0000001FFFFFFFFC0000001
+FFFFFFFFC03B5F7DDE42>52 D<000003FF80000000001FFFF800000000FFFFFE00000003
+FFFFFF80000007FE00FFE000001FE0001FF000003F800007FC00007E000001FE0000FC00
+0000FF0001F80000007F0001F00000003F8003E00000001FC007E00000000FC007C00000
+000FE00FC000000007E00FC000000007E00F8000000007F01F8000000003F01F80000000
+03F01F8000000003F01F8000000003F01F8000000003F01FC000000003F01FC000000003
+F01FE000000007F01FE000000007E01FF000000007E00FF80000000FE00FFC0000000FC0
+0FFE0000000FC007FF0000001F8007FFC000003F8003FFE000003F0003FFF800007E0001
+FFFC0000FC0000FFFE0001F80000FFFF8003F000007FFFC00FE000003FFFF01F8000000F
+FFF83F00000007FFFEFC00000001FFFFF000000000FFFFE0000000003FFFE0000000001F
+FFF8000000000FFFFC000000001FFFFE000000007FFFFF80000001F87FFFC0000003F03F
+FFF000000FC00FFFF800001F8007FFFC00003F0001FFFF00007E0000FFFF8000FC00003F
+FF8001F800001FFFC003F000000FFFE007E0000003FFF00FC0000001FFF00FC00000007F
+F81F800000003FF83F800000001FF83F000000000FFC7F0000000007FC7E0000000003FC
+7E0000000003FE7E0000000001FEFE0000000000FEFC0000000000FEFC0000000000FEFC
+00000000007EFC00000000007EFC00000000007EFC00000000007EFC00000000007EFC00
+000000007EFE00000000007C7E0000000000FC7E0000000000FC7F0000000000F83F0000
+000001F83F8000000001F01F8000000003F01FC000000003E00FE000000007E007F00000
+000FC007F80000001F8003FC0000003F0001FE000000FE00007F800001FC00003FE0000F
+F000000FFE007FE0000007FFFFFF80000001FFFFFE000000003FFFF80000000003FF8000
+0037607BDD42>56 D<0000000000FFF0000000C000000000000FFFFF000001C000000000
+007FFFFFE00001C00000000003FFFFFFF80003C0000000000FFFE003FE0003C000000000
+3FFC00007F0007C000000000FFE000000FC007C000000003FF80000003E00FC000000007
+FE00000001F01FC00000000FFC00000000781FC00000003FF0000000003C3FC00000007F
+E0000000001E3FC0000000FFC0000000000F7FC0000001FF800000000007FFC0000003FF
+000000000003FFC0000007FE000000000003FFC000000FFC000000000001FFC000001FF8
+000000000000FFC000001FF0000000000000FFC000003FF00000000000007FC000007FE0
+0000000000003FC00000FFC00000000000003FC00000FFC00000000000001FC00001FF80
+0000000000001FC00001FF800000000000000FC00003FF000000000000000FC00003FF00
+0000000000000FC00007FE0000000000000007C00007FE0000000000000007C0000FFC00
+00000000000007C0000FFC0000000000000003C0001FFC0000000000000003C0001FF800
+00000000000003C0001FF80000000000000003C0003FF80000000000000003C0003FF800
+00000000000001C0003FF00000000000000001C0003FF00000000000000001C0007FF000
+00000000000001C0007FF0000000000000000000007FF0000000000000000000007FF000
+0000000000000000007FE000000000000000000000FFE000000000000000000000FFE000
+000000000000000000FFE000000000000000000000FFE000000000000000000000FFE000
+000000000000000000FFE000000000000000000000FFE000000000000000000000FFE000
+000000000000000000FFE000000000000000000000FFE000000000000000000000FFE000
+000000000000000000FFE000000000000000000000FFE000000000000000000000FFE000
+000000000000000000FFE000000000000000000000FFE0000000000000000000007FF000
+0000000000000000007FF0000000000000000000007FF00000000001FFFFFFFFE07FF000
+00000001FFFFFFFFE07FF00000000001FFFFFFFFE03FF00000000001FFFFFFFFE03FF000
+00000000000FFFF0003FF800000000000001FFE0003FF800000000000001FFC0001FF800
+000000000000FFC0001FFC00000000000000FFC0001FFC00000000000000FFC0000FFC00
+000000000000FFC0000FFE00000000000000FFC00007FE00000000000000FFC00007FE00
+000000000000FFC00003FF00000000000000FFC00003FF00000000000000FFC00001FF80
+000000000000FFC00001FF80000000000000FFC00000FFC0000000000000FFC00000FFC0
+000000000000FFC000007FE0000000000000FFC000003FF0000000000000FFC000001FF0
+000000000000FFC000001FF8000000000000FFC000000FFC000000000000FFC0000007FE
+000000000001FFC0000003FF000000000001FFC0000001FF800000000003FFC0000000FF
+C00000000003FFC00000007FE00000000007BFC00000003FF8000000000F3FC00000000F
+FC000000001F1FC000000007FF000000003E1FC000000003FFC0000000FC0FC000000000
+FFF0000001F807C0000000003FFE00000FE007C0000000000FFFF000FF8003C000000000
+03FFFFFFFE0001C000000000007FFFFFF80000C000000000000FFFFFC000000000000000
+0000FFF800000000005B667AE368>71 D<000007FF0000030000003FFFF00007000001FF
+FFFC0007000007FFFFFF000F00000FFC00FFC00F00003FE0000FF01F00007F800003F81F
+0000FE000000FC3F0001FC0000007E3F0003F80000001F7F0007F00000000FFF000FE000
+000007FF000FC000000007FF001FC000000003FF001F8000000001FF003F8000000000FF
+003F0000000000FF007F00000000007F007F00000000007F007E00000000003F007E0000
+0000003F00FE00000000003F00FE00000000001F00FE00000000001F00FE00000000001F
+00FE00000000000F00FE00000000000F00FF00000000000F00FF00000000000F00FF0000
+0000000F00FF80000000000700FF800000000007007FC00000000007007FC00000000007
+007FE00000000000003FF00000000000003FF80000000000003FFC0000000000001FFE00
+00000000001FFF8000000000000FFFE0000000000007FFFC000000000007FFFFC0000000
+0003FFFFF80000000001FFFFFF8000000000FFFFFFF8000000007FFFFFFF800000001FFF
+FFFFE00000000FFFFFFFF800000003FFFFFFFE00000000FFFFFFFF800000001FFFFFFFC0
+00000001FFFFFFE0000000003FFFFFF00000000003FFFFF800000000003FFFFC00000000
+0003FFFE0000000000007FFE0000000000001FFF0000000000000FFF80000000000003FF
+80000000000001FFC0000000000000FFC0000000000000FFC00000000000007FE0000000
+0000003FE00000000000003FE00000000000001FE0E000000000001FF0E000000000000F
+F0E000000000000FF0E000000000000FF0E000000000000FF0E0000000000007F0E00000
+00000007F0F0000000000007F0F0000000000007F0F0000000000007F0F0000000000007
+F0F8000000000007F0F8000000000007E0F800000000000FE0FC00000000000FE0FC0000
+0000000FC0FE00000000000FC0FF00000000001FC0FF00000000001F80FF80000000003F
+80FFC0000000003F00FFE0000000007F00FFF000000000FE00FEF800000000FC00FEFC00
+000001F800FC7F00000003F800FC1F8000000FF000F80FE000001FE000F807FC00007F80
+00F001FFE003FF0000F0007FFFFFFC0000E0001FFFFFF00000E00003FFFFC00000C00000
+1FFE0000003C667AE349>83 D<FFFFFFFF0000001FFFFFF0FFFFFFFF0000001FFFFFF0FF
+FFFFFF0000001FFFFFF0FFFFFFFF0000001FFFFFF000FFFF0000000000FFFE00003FFC00
+000000003FF800001FF800000000000FE000001FF800000000000FE000001FF800000000
+0007C000001FF8000000000007C000001FF80000000000038000001FF800000000000380
+00001FF80000000000038000001FF80000000000038000001FF80000000000038000001F
+F80000000000038000001FF80000000000038000001FF80000000000038000001FF80000
+000000038000001FF80000000000038000001FF80000000000038000001FF80000000000
+038000001FF80000000000038000001FF80000000000038000001FF80000000000038000
+001FF80000000000038000001FF80000000000038000001FF80000000000038000001FF8
+0000000000038000001FF80000000000038000001FF80000000000038000001FF8000000
+0000038000001FF80000000000038000001FF80000000000038000001FF8000000000003
+8000001FF80000000000038000001FF80000000000038000001FF8000000000003800000
+1FF80000000000038000001FF80000000000038000001FF80000000000038000001FF800
+00000000038000001FF80000000000038000001FF80000000000038000001FF800000000
+00038000001FF80000000000038000001FF80000000000038000001FF800000000000380
+00001FF80000000000038000001FF80000000000038000001FF80000000000038000001F
+F80000000000038000001FF80000000000038000001FF80000000000038000001FF80000
+000000038000001FF80000000000038000001FF80000000000038000001FF80000000000
+038000001FF80000000000038000001FF80000000000038000001FF80000000000038000
+001FF80000000000038000001FF80000000000038000001FF80000000000038000001FF8
+0000000000038000001FF80000000000038000001FF80000000000038000001FF8000000
+0000038000001FF80000000000038000001FF80000000000038000001FF8000000000003
+8000001FF80000000000078000000FF80000000000070000000FFC000000000007000000
+0FFC0000000000070000000FFC00000000000700000007FC00000000000F00000007FC00
+000000000E00000007FE00000000001E00000003FE00000000001E00000003FE00000000
+001C00000001FF00000000003C00000001FF00000000003800000000FF80000000007800
+000000FF8000000000F0000000007FC000000000F0000000003FC000000001E000000000
+3FE000000003C0000000001FF000000007C0000000000FF80000000F800000000007FC00
+00001F000000000003FE0000003E000000000001FF000000FC0000000000007FC00001F8
+0000000000003FF0000FF00000000000000FFE007FC000000000000003FFFFFF00000000
+00000000FFFFFC00000000000000003FFFF0000000000000000003FF8000000000546479
+E163>85 D<000001FF80000000000FFFF8000000003FFFFE00000000FF007F80000003FC
+0007E0000007F00001F000001FE000007800003FC000003C00007F8000001E0000FF0000
+000F0001FE0000001F0001FC000000FF0003FC000001FF8007F8000003FF8007F8000003
+FF800FF0000003FF800FF0000003FF801FE0000003FF801FE0000003FF803FE0000001FF
+003FC00000007C003FC000000000007FC000000000007FC000000000007FC00000000000
+7F800000000000FF800000000000FF800000000000FF800000000000FF800000000000FF
+800000000000FF800000000000FF800000000000FF800000000000FF800000000000FF80
+0000000000FF800000000000FF800000000000FF8000000000007F8000000000007FC000
+000000007FC000000000007FC000000000007FC000000000003FC000000000003FE00000
+0000003FE000000000001FE000000001C01FF000000001C00FF000000003C00FF8000000
+038007F8000000038003FC000000078003FE000000070001FE0000000F0000FF0000001E
+00007F8000003C00003FC000007800001FE00000F000000FF80001E0000003FC0007C000
+0000FF803F800000003FFFFE000000000FFFF80000000001FF80000032417CBF3A>99
+D<0000000000001E000000000000003FFE00000000000007FFFE00000000000007FFFE00
+000000000007FFFE00000000000007FFFE000000000000000FFE0000000000000003FE00
+00000000000003FE0000000000000001FE0000000000000001FE0000000000000001FE00
+00000000000001FE0000000000000001FE0000000000000001FE0000000000000001FE00
+00000000000001FE0000000000000001FE0000000000000001FE0000000000000001FE00
+00000000000001FE0000000000000001FE0000000000000001FE0000000000000001FE00
+00000000000001FE0000000000000001FE0000000000000001FE0000000000000001FE00
+00000000000001FE0000000000000001FE0000000000000001FE0000000000000001FE00
+00000000000001FE0000000000000001FE0000000000000001FE0000000000000001FE00
+00000000000001FE0000000000FF8001FE000000000FFFF801FE000000003FFFFE01FE00
+000000FF803F81FE00000003FC0007C1FE00000007F80001E1FE0000001FE00000F9FE00
+00003FC000007DFE0000007F8000003DFE000000FF0000001FFE000001FE0000000FFE00
+0001FC00000007FE000003FC00000007FE000007F800000003FE000007F000000001FE00
+000FF000000001FE00001FF000000001FE00001FE000000001FE00001FE000000001FE00
+003FE000000001FE00003FC000000001FE00007FC000000001FE00007FC000000001FE00
+007FC000000001FE00007FC000000001FE00007F8000000001FE0000FF8000000001FE00
+00FF8000000001FE0000FF8000000001FE0000FF8000000001FE0000FF8000000001FE00
+00FF8000000001FE0000FF8000000001FE0000FF8000000001FE0000FF8000000001FE00
+00FF8000000001FE0000FF8000000001FE0000FF8000000001FE0000FF8000000001FE00
+007F8000000001FE00007FC000000001FE00007FC000000001FE00007FC000000001FE00
+003FC000000001FE00003FC000000001FE00003FE000000001FE00001FE000000001FE00
+001FE000000001FE00000FF000000003FE00000FF000000003FE000007F800000007FE00
+0003F800000007FE000003FC0000000FFE000001FE0000001FFE000000FE0000003DFE00
+00007F0000003DFE0000003F800000F9FF0000001FC00001F1FF0000000FF00003C1FFC0
+000007F8000F81FFFF800001FF007F01FFFF8000007FFFFC01FFFF8000001FFFE001FFFF
+80000001FF0001FF000041657CE349>I<000003FE00000000001FFFE000000000FFFFF8
+00000001FE03FE00000007F0007F8000000FE0003FC000003FC0001FE000007F00000FF0
+0000FF000007F80000FE000003F80001FC000003FC0003F8000001FC0007F8000001FE00
+07F0000000FE000FF0000000FF000FF00000007F001FE00000007F001FE00000007F803F
+E00000007F803FC00000003F803FC00000003F807FC00000003FC07FC00000003FC07FC0
+0000003FC07F800000003FC07F800000003FC0FF800000003FC0FFFFFFFFFFFFC0FFFFFF
+FFFFFFC0FFFFFFFFFFFFC0FF800000000000FF800000000000FF800000000000FF800000
+000000FF800000000000FF800000000000FF800000000000FF800000000000FF80000000
+00007F8000000000007FC000000000007FC000000000007FC000000000003FC000000000
+003FC000000000003FE000000000001FE000000000001FE000000001C00FF000000001C0
+0FF000000003C007F8000000038007F8000000038003FC000000078001FC0000000F0001
+FE0000000E0000FF0000001E00007F8000003C00003FC000007800001FE00000F0000007
+F00003E0000003FC0007C0000000FF803F000000003FFFFC000000000FFFF00000000001
+FF80000032417CBF3A>I<0003C000000000000007FFC0000000000000FFFFC000000000
+0000FFFFC0000000000000FFFFC0000000000000FFFFC000000000000001FFC000000000
+0000007FC0000000000000007FC0000000000000003FC0000000000000003FC000000000
+0000003FC0000000000000003FC0000000000000003FC0000000000000003FC000000000
+0000003FC0000000000000003FC0000000000000003FC0000000000000003FC000000000
+0000003FC0000000000000003FC0000000000000003FC0000000000000003FC000000000
+0000003FC0000000000000003FC0000000000000003FC0000000000000003FC000000000
+0000003FC0000000000000003FC0000000000000003FC0000000000000003FC000000000
+0000003FC0000000000000003FC0000000000000003FC0000000000000003FC000000000
+0000003FC0000000000000003FC0000000000000003FC0007FE0000000003FC003FFFC00
+0000003FC00FFFFF000000003FC03F00FFC00000003FC078001FE00000003FC0F0000FF0
+0000003FC1C00007F80000003FC3800007FC0000003FC7000003FC0000003FCE000003FE
+0000003FCE000001FE0000003FDC000001FE0000003FD8000001FE0000003FF8000000FF
+0000003FF0000000FF0000003FF0000000FF0000003FF0000000FF0000003FE0000000FF
+0000003FE0000000FF0000003FE0000000FF0000003FC0000000FF0000003FC0000000FF
+0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF
+0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF
+0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF
+0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF
+0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF
+0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF
+0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF
+0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF
+0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000007FE0000001FF
+800000FFF0000003FFC000FFFFFFF003FFFFFFC0FFFFFFF003FFFFFFC0FFFFFFF003FFFF
+FFC0FFFFFFF003FFFFFFC042647DE349>104 D<003C000000FF000001FF800003FFC000
+03FFC00003FFC00003FFC00003FFC00003FFC00001FF800000FF0000003C000000000000
+000000000000000000000000000000000000000000000000000000000000000000000000
+000000000000000000000000000000000000000000000000000000000000000000000000
+000000000003C00007FFC0007FFFC0007FFFC0007FFFC0007FFFC00001FFC000007FC000
+007FC000003FC000003FC000003FC000003FC000003FC000003FC000003FC000003FC000
+003FC000003FC000003FC000003FC000003FC000003FC000003FC000003FC000003FC000
+003FC000003FC000003FC000003FC000003FC000003FC000003FC000003FC000003FC000
+003FC000003FC000003FC000003FC000003FC000003FC000003FC000003FC000003FC000
+003FC000003FC000003FC000003FC000003FC000003FC000003FC000003FC000003FC000
+003FC000003FC000003FC000003FC000007FE00000FFF000FFFFFFE0FFFFFFE0FFFFFFE0
+FFFFFFE01B5F7DDE23>I<0003C000FFC0000007FE00000007FFC003FFF800001FFFC000
+00FFFFC00FFFFE00007FFFF00000FFFFC03F00FF8001F807FC0000FFFFC078003FC003C0
+01FE0000FFFFC1E0001FE00F0000FF000001FFC3C0000FF01E00007F8000007FC3800007
+F81C00003FC000007FC7000007F83800003FC000003FCE000003FC7000001FE000003FCC
+000003FC6000001FE000003FDC000003FCE000001FE000003FD8000003FCC000001FE000
+003FF8000001FFC000000FF000003FF0000001FF8000000FF000003FF0000001FF800000
+0FF000003FE0000001FF0000000FF000003FE0000001FF0000000FF000003FE0000001FF
+0000000FF000003FE0000001FF0000000FF000003FC0000001FE0000000FF000003FC000
+0001FE0000000FF000003FC0000001FE0000000FF000003FC0000001FE0000000FF00000
+3FC0000001FE0000000FF000003FC0000001FE0000000FF000003FC0000001FE0000000F
+F000003FC0000001FE0000000FF000003FC0000001FE0000000FF000003FC0000001FE00
+00000FF000003FC0000001FE0000000FF000003FC0000001FE0000000FF000003FC00000
+01FE0000000FF000003FC0000001FE0000000FF000003FC0000001FE0000000FF000003F
+C0000001FE0000000FF000003FC0000001FE0000000FF000003FC0000001FE0000000FF0
+00003FC0000001FE0000000FF000003FC0000001FE0000000FF000003FC0000001FE0000
+000FF000003FC0000001FE0000000FF000003FC0000001FE0000000FF000003FC0000001
+FE0000000FF000003FC0000001FE0000000FF000003FC0000001FE0000000FF000003FC0
+000001FE0000000FF000003FC0000001FE0000000FF000003FC0000001FE0000000FF000
+003FC0000001FE0000000FF000003FC0000001FE0000000FF000003FC0000001FE000000
+0FF000003FC0000001FE0000000FF000003FC0000001FE0000000FF000003FC0000001FE
+0000000FF000003FC0000001FE0000000FF000003FC0000001FE0000000FF000007FE000
+0003FF0000001FF80000FFF0000007FF8000003FFC00FFFFFFF007FFFFFF803FFFFFFCFF
+FFFFF007FFFFFF803FFFFFFCFFFFFFF007FFFFFF803FFFFFFCFFFFFFF007FFFFFF803FFF
+FFFC663F7CBE6F>109 D<00078003F80007FF800FFF00FFFF803FFFC0FFFF807C0FE0FF
+FF81F01FE0FFFF81E03FF001FF83803FF0007F87003FF0007F8F003FF0003F8E003FF000
+3F9C001FE0003F9C000FC0003F98000300003FB8000000003FB8000000003FB000000000
+3FF0000000003FF0000000003FE0000000003FE0000000003FE0000000003FE000000000
+3FE0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC000000000
+3FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC000000000
+3FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC000000000
+3FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC000000000
+3FC0000000003FC0000000003FC0000000003FC0000000003FC0000000003FC000000000
+3FC0000000003FC0000000003FC0000000003FC0000000003FC0000000007FE000000000
+FFF8000000FFFFFFFC0000FFFFFFFC0000FFFFFFFC0000FFFFFFFC00002C3F7CBE33>
+114 D<0000FFE00180000FFFFC0380007FFFFF078001FF001FCF8003F80003EF8007E000
+01FF800FC00000FF801F8000007F803F0000003F803E0000001F807E0000000F807C0000
+000F807C0000000F80FC0000000780FC0000000780FC0000000780FC0000000380FE0000
+000380FE0000000380FF0000000380FF80000003807FC0000003807FE0000000007FF800
+0000003FFE000000001FFFF00000000FFFFF80000007FFFFF8000003FFFFFF000001FFFF
+FFC000007FFFFFF000001FFFFFF8000007FFFFFE0000007FFFFF00000003FFFF80000000
+3FFFC000000003FFC000000000FFE0000000007FE0E00000001FF0E00000000FF0E00000
+000FF8F000000007F8F000000003F8F000000003F8F000000003F8F800000001F8F80000
+0001F8F800000001F8FC00000001F8FC00000001F8FE00000001F0FE00000003F0FF0000
+0003F0FF00000003E0FF80000007E0FFC000000FC0FFE000000F80FDF000001F80F8F800
+007F00F83E0000FC00F01FC00FF800F007FFFFE000E001FFFF8000C0003FF800002D417D
+BF34>I<0003C00000000F000007FFC000001FFF0000FFFFC00003FFFF0000FFFFC00003
+FFFF0000FFFFC00003FFFF0000FFFFC00003FFFF000001FFC0000007FF0000007FC00000
+01FF0000007FC0000001FF0000003FC0000000FF0000003FC0000000FF0000003FC00000
+00FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC00000
+00FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC00000
+00FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC00000
+00FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC00000
+00FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC00000
+00FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC00000
+00FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC00000
+00FF0000003FC0000000FF0000003FC0000000FF0000003FC0000000FF0000003FC00000
+00FF0000003FC0000000FF0000003FC0000001FF0000003FC0000001FF0000003FC00000
+01FF0000003FC0000003FF0000003FC0000003FF0000003FC0000003FF0000003FC00000
+07FF0000001FC0000006FF0000001FE000000EFF0000001FE000001CFF0000000FE00000
+1CFF0000000FF0000038FF80000007F0000070FF80000003F80001E0FFE0000001FE0003
+C0FFFFC00000FFC01F80FFFFC000003FFFFE00FFFFC000000FFFF800FFFFC0000000FFC0
+00FF800042407DBE49>117 D E end
+%%EndProlog
+%%BeginSetup
+%%Feature: *Resolution 600dpi
+TeXDict begin
+%%PaperSize: Letter
+
+%%EndSetup
+%%Page: 1 1
+1 0 bop 1256 872 a Fk(Sc)l(heme)44 b(48)f(User's)g(Guide)1557
+1112 y Fj(Ric)m(hard)32 b(A.)h(Kelsey)1778 1411 y Fi(Abstract)837
+1542 y Fh(Some)25 b(of)i(Sc)n(heme)d(48's)j(w)n(onderful)f(features.)
+515 1816 y Fg(1)134 b(ASCI)t(I)45 b(c)l(haracter)g(enco)t(ding)515
+1998 y Ff(These)27 b(are)g(in)g(the)h(structure)g Fe(ascii)p
+Ff(.)531 2147 y Fd(\017)41 b Fe(\(char->ascii)c Fc(char)9
+b Fe(\))42 b Fd(!)g Fc(inte)l(ger)531 2247 y Fd(\017)f
+Fe(\(ascii->char)c Fc(inte)l(ger)9 b Fe(\))41 b Fd(!)h
+Fc(char)515 2396 y Ff(These)23 b(are)f(iden)n(tical)h(to)g
+Fe(char->integer)18 b Ff(and)23 b Fe(integer->char)18
+b Ff(except)23 b(that)h(they)f(use)515 2496 y(the)28
+b(ASCI)r(I)g(enco)r(ding.)531 2645 y Fd(\017)41 b Ff(ascii-limit)2162
+b(in)n(teger)531 2745 y Fd(\017)41 b Ff(ascii-whitespaces)1640
+b(list)28 b(of)f(in)n(tegers)515 2895 y Fe(Ascii-limit)21
+b Ff(is)k(one)h(more)e(than)i(the)g(largest)e(v)-5 b(alue)26
+b(that)f Fe(char->ascii)d Ff(ma)n(y)i(return.)515 2994
+y Fe(Ascii-whitespace)o(s)12 b Ff(is)19 b(a)f(list)h(of)g(the)g(ASCI)r
+(I)g(v)-5 b(alues)18 b(of)h(whitespace)f(c)n(haracters)e(\(space,)515
+3094 y(tab,)27 b(line)h(feed,)g(form)f(feed,)i(and)e(carriage)e
+(return\).)515 3368 y Fg(2)134 b(Bit)l(wise)47 b(in)l(teger)f(op)t
+(erations)515 3550 y Ff(These)27 b(functions)g(use)h(the)f(t)n(w)n
+(o's-complemen)n(t)f(represen)n(tation)g(for)h(in)n(tegers.)35
+b(There)27 b(is)515 3650 y(no)c(limit)h(to)g(the)f(n)n(um)n(b)r(er)h
+(of)f(bits)h(in)g(an)f(in)n(teger.)35 b(They)23 b(are)f(in)i(the)g
+(structures)f Fe(bitwise)515 3749 y Ff(and)k Fe(big-scheme)p
+Ff(.)531 3899 y Fd(\017)41 b Fe(\(bitwise-and)c Fc(inte)l(ger)k(inte)l
+(ger)9 b Fe(\))42 b Fd(!)f Fc(inte)l(ger)531 3999 y Fd(\017)g
+Fe(\(bitwise-ior)c Fc(inte)l(ger)k(inte)l(ger)9 b Fe(\))42
+b Fd(!)f Fc(inte)l(ger)531 4098 y Fd(\017)g Fe(\(bitwise-xor)c
+Fc(inte)l(ger)k(inte)l(ger)9 b Fe(\))42 b Fd(!)f Fc(inte)l(ger)531
+4198 y Fd(\017)g Fe(\(bitwise-not)c Fc(inte)l(ger)9 b
+Fe(\))41 b Fd(!)h Fc(inte)l(ger)515 4347 y Ff(These)24
+b(p)r(erform)g(v)-5 b(arious)24 b(logical)f(op)r(erations)g(on)h(in)n
+(tegers)g(on)g(a)g(bit-b)n(y-bit)h(basis.)35 b(`)p Fe(ior)p
+Ff(')515 4447 y(is)27 b(inclusiv)n(e)g(OR)h(and)f(`)p
+Fe(xor)p Ff(')g(is)g(exclusiv)n(e)g(OR.)531 4596 y Fd(\017)41
+b Fe(\(arithmetic-shift)35 b Fc(inte)l(ger)41 b(bit-c)l(ount)8
+b Fe(\))41 b Fd(!)g Fc(inte)l(ger)515 4746 y Ff(Shifts)26
+b(the)g(in)n(teger)f(b)n(y)g(the)h(giv)n(en)f(bit)h(coun)n(t,)g(whic)n
+(h)f(m)n(ust)h(b)r(e)g(an)f(in)n(teger,)g(shifting)h(left)515
+4845 y(for)i(p)r(ositiv)n(e)h(coun)n(ts)g(and)g(righ)n(t)g(for)f
+(negativ)n(e)g(ones.)41 b(Shifting)30 b(preserv)n(es)e(the)h(in)n
+(teger's)515 4945 y(sign.)1926 5255 y(1)p eop
+%%Page: 2 2
+2 1 bop 515 523 a Fg(3)134 b(Arra)l(ys)515 705 y Ff(These)27
+b(are)g(N-dimensional,)g(zero-based)e(arra)n(ys)g(and)j(are)e(in)i(the)
+g(structure)f Fe(arrays)p Ff(.)639 805 y(The)h(arra)n(y)d(in)n(terface)
+i(is)h(deriv)n(ed)e(from)i(one)f(written)h(b)n(y)f(Alan)h(Ba)n(wden.)
+531 945 y Fd(\017)41 b Fe(\(make-array)c Fc(value)42
+b(dimension)1729 957 y Fb(0)1809 945 y Fc(.)13 b(.)g(.)g
+Fe(\))51 b Fd(!)42 b Fc(arr)l(ay)531 1045 y Fd(\017)f
+Fe(\(array)e Fc(dimensions)k(element)1640 1057 y Fb(0)1719
+1045 y Fc(.)13 b(.)g(.)g Fe(\))51 b Fd(!)41 b Fc(arr)l(ay)531
+1144 y Fd(\017)g Fe(\(copy-array)c Fc(arr)l(ay)7 b Fe(\))43
+b Fd(!)e Fc(arr)l(ay)515 1285 y Fe(Make-array)23 b Ff(mak)n(es)k(a)g
+(new)h(arra)n(y)d(with)j(the)g(giv)n(en)f(dimensions,)g(eac)n(h)g(of)g
+(whic)n(h)h(m)n(ust)515 1385 y(b)r(e)22 b(a)g(non-negativ)n(e)e(in)n
+(teger.)34 b(Ev)n(ery)21 b(elemen)n(t)h(is)g(initially)g(set)g(to)g
+Fc(value)p Ff(.)36 b Fe(Array)20 b Ff(Returns)515 1484
+y(a)33 b(new)h(arra)n(y)e(with)i(the)h(giv)n(en)e(dimensions)g(and)h
+(elemen)n(ts.)56 b Fc(Dimensions)34 b Ff(m)n(ust)g(b)r(e)g(a)515
+1584 y(list)24 b(of)f(non-negativ)n(e)f(in)n(tegers,)h(The)h(n)n(um)n
+(b)r(er)g(of)f(elemen)n(ts)h(should)f(b)r(e)h(the)g(equal)f(to)h(the)
+515 1683 y(pro)r(duct)j(of)h(the)g(dimensions.)36 b(The)28
+b(elemen)n(ts)g(are)e(stored)h(in)h(ro)n(w-ma)5 b(jor)24
+b(order.)680 1841 y Fe(\(make-array)39 b('a)k(2)g(3\))g
+Fd(!)g(f)p Fe(Array)e(2)j(3)p Fd(g)680 2040 y Fe(\(array)d('\(2)i(3\))f
+('a)h('b)g('c)g('d)f('e)h('f\))854 2139 y Fd(!)h(f)p
+Fe(Array)d(2)i(3)p Fd(g)639 2297 y Fe(Copy-array)25 b
+Ff(returns)i(a)h(cop)n(y)g(of)g Fc(arr)l(ay)p Ff(.)40
+b(The)28 b(cop)n(y)g(is)g(iden)n(tical)g(to)g(the)h Fc(arr)l(ay)g
+Ff(but)515 2396 y(do)r(es)e(not)h(share)e(storage)g(with)i(it.)531
+2537 y Fd(\017)41 b Fe(\(array?)47 b Fc(value)6 b Fe(\))42
+b Fd(!)g Fc(b)l(o)l(ole)l(an)515 2677 y Ff(Returns)27
+b Fe(#t)g Ff(if)h Fc(value)g Ff(is)g(an)f(arra)n(y)-7
+b(.)531 2818 y Fd(\017)41 b Fe(\(array-ref)d Fc(arr)l(ay)k(index)1515
+2830 y Fb(0)1594 2818 y Fc(.)13 b(.)g(.)g Fe(\))51 b
+Fd(!)42 b Fc(value)531 2918 y Fd(\017)f Fe(\(array-set!)c
+Fc(arr)l(ay)43 b(value)f(index)1785 2930 y Fb(0)1864
+2918 y Fc(.)13 b(.)g(.)g Fe(\))531 3017 y Fd(\017)41
+b Fe(\(array->vector)36 b Fc(arr)l(ay)7 b Fe(\))42 b
+Fd(!)g Fc(ve)l(ctor)531 3117 y Fd(\017)f Fe(\(array-dimensions)35
+b Fc(arr)l(ay)7 b Fe(\))42 b Fd(!)g Fc(list)515 3257
+y Fe(Array-ref)32 b Ff(returns)j(the)i(sp)r(eci\014ed)f(arra)n(y)d
+(elemen)n(t)j(and)g Fe(array-set!)58 b Ff(replaces)35
+b(the)515 3357 y(elemen)n(t)27 b(with)i Fc(value)p Ff(.)680
+3514 y Fe(\(let)42 b(\(\(a)g(\(array)f('\(2)i(3\))g('a)f('b)h('c)g('d)g
+('e)f('f\)\)\))767 3614 y(\(let)g(\(\(x)h(\(array-ref)c(a)k(0)g
+(1\)\)\))854 3713 y(\(array-set!)c(a)44 b('g)e(0)i(1\))854
+3813 y(\(list)e(x)h(\(array-ref)d(a)j(0)g(1\)\)\)\))854
+3913 y Fd(!)h Fe('\(b)e(g\))639 4070 y(Array->vector)31
+b Ff(returns)k(a)h(v)n(ector)f(con)n(taining)g(the)h(elemen)n(ts)g(of)g
+Fc(arr)l(ay)h Ff(in)g(ro)n(w-)515 4169 y(ma)5 b(jor)26
+b(order.)36 b Fe(Array-dimension)o(s)22 b Ff(returns)27
+b(the)h(dimensions)f(of)g(the)h(arra)n(y)e(as)h(a)g(list.)531
+4310 y Fd(\017)41 b Fe(\(make-shared-arra)o(y)35 b Fc(arr)l(ay)43
+b(line)l(ar-map)g(dimension)2470 4322 y Fb(0)2550 4310
+y Fc(.)13 b(.)g(.)g Fe(\))50 b Fd(!)42 b Fc(arr)l(ay)515
+4451 y Fe(Make-shared-arra)o(y)34 b Ff(mak)n(es)40 b(a)g(new)h(arra)n
+(y)d(that)j(shares)f(storage)e(with)k Fc(arr)l(ay)f Ff(and)515
+4550 y(uses)28 b Fc(line)l(ar-map)h Ff(to)f(map)g(indicies)h(to)f
+(elemen)n(ts.)38 b Fc(Line)l(ar-map)30 b Ff(m)n(ust)e(accept)g(as)g
+(man)n(y)515 4650 y(argumen)n(ts)33 b(as)g(the)i(n)n(um)n(b)r(er)f(of)g
+Fc(dimension)p Ff(s)h(giv)n(en)f(and)g(m)n(ust)g(return)g(a)g(list)g
+(of)h(non-)515 4749 y(negativ)n(e)26 b(in)n(tegers)h(that)h(are)e(v)-5
+b(alid)28 b(indicies)f(in)n(to)h Fc(arr)l(ay)p Ff(.)680
+4907 y Fe(\(array-ref)40 b(\(make-shared-ar)o(ray)d(a)43
+b(f)g(i0)g(i1)g(...\))1160 5006 y(j0)f(j1)h(...\))1926
+5255 y Ff(2)p eop
+%%Page: 3 3
+3 2 bop 515 523 a Ff(is)27 b(equiv)-5 b(alen)n(t)28 b(to)680
+689 y Fe(\(apply)41 b(array-ref)f(a)j(\(f)g(j0)g(j1)g(...\)\))639
+855 y Ff(As)19 b(an)f(example,)i(the)e(follo)n(wing)g(function)h(mak)n
+(es)e(the)i(transp)r(ose)e(of)h(a)g(t)n(w)n(o-dimensional)515
+955 y(arra)n(y:)680 1121 y Fe(\(define)41 b(\(transpose)e(array\))767
+1220 y(\(let)j(\(\(dimensions)d(\(array-dimension)o(s)e(array\)\)\))854
+1320 y(\(make-shared-arra)o(y)h(array)1683 1420 y(\(lambda)i(\(x)j(y\))
+1072 1519 y(\(list)f(y)h(x\)\))985 1619 y(\(cadr)f(dimensions\))985
+1719 y(\(car)g(dimensions\)\)\)\))680 1918 y(\(array->vector)767
+2017 y(\(transpose)854 2117 y(\(array)g('\(2)g(3\))h('a)f('b)h('c)g('d)
+g('e)f('f\)\)\))942 2217 y Fd(!)h Fe('\(a)g(d)g(b)g(e)g(c)g(f\))515
+2491 y Fg(4)134 b(Records)515 2673 y Ff(New)29 b(t)n(yp)r(es)f(can)h(b)
+r(e)g(constructed)f(using)g(the)i Fe(define-record-t)o(yp)o(e)23
+b Ff(macro)k(from)i(the)515 2773 y Fe(define-record-ty)o(pe)o(s)22
+b Ff(structure)27 b(The)g(general)f(syn)n(tax)h(is:)680
+2939 y Fe(\(define-record-t)o(ype)37 b Fc(tag)44 b(typ)l(e-name)767
+3038 y Fe(\()p Fc(c)l(onstructor-name)f(\014eld-tag)h
+Fe(...\))767 3138 y Fc(pr)l(e)l(dic)l(ate-name)767 3238
+y Fe(\()p Fc(\014eld-tag)g(ac)l(c)l(essor-name)g Fe([)p
+Fc(mo)l(di\014er-name)p Fe(]\))767 3337 y(...\))515 3503
+y Ff(This)27 b(mak)n(es)g(the)h(follo)n(wing)e(de\014nitions:)531
+3669 y Fd(\017)41 b Fc(typ)l(e-name)2237 b Ff(t)n(yp)r(e)531
+3769 y Fd(\017)41 b Fe(\()p Fc(c)l(onstructor-name)g(\014eld-init)h(.)
+13 b(.)g(.)g Fe(\))51 b Fd(!)41 b Fc(typ)l(e-name)531
+3869 y Fd(\017)g Fe(\()p Fc(pr)l(e)l(dic)l(ate-name)i(value)6
+b Fe(\))41 b Fd(!)h Fc(b)l(o)l(ole)l(an)531 3968 y Fd(\017)f
+Fe(\()p Fc(ac)l(c)l(essor-name)h(typ)l(e-name)6 b Fe(\))42
+b Fd(!)f Fc(value)531 4068 y Fd(\017)g Fe(\()p Fc(mo)l(di\014er-name)h
+(typ)l(e-name)g(value)6 b Fe(\))515 4234 y Fc(T)-6 b(yp)l(e-name)29
+b Ff(is)f(the)g(record)f(t)n(yp)r(e)i(itself,)f(and)g(can)g(b)r(e)h
+(used)f(to)g(sp)r(ecify)h(a)e(prin)n(t)i(metho)r(d)515
+4334 y(\(see)22 b(b)r(elo)n(w\).)35 b Fc(Constructor-name)23
+b Ff(is)f(a)g(constructor)f(that)i(accepts)f(v)-5 b(alues)22
+b(for)g(the)h(\014elds)515 4433 y(whose)j(tags)g(are)f(sp)r(eci\014ed.)
+37 b Fc(Pr)l(e)l(dic)l(ate-name)28 b Ff(to)f(a)f(predicate)g(that)h
+(can)g(returns)f Fe(#t)g Ff(for)515 4533 y(elemen)n(ts)33
+b(of)h(the)f(t)n(yp)r(e)h(and)f Fe(#f)g Ff(for)g(ev)n(erything)g(else.)
+54 b(The)33 b Fc(ac)l(c)l(essor-name)p Ff(s)h(retriev)n(e)515
+4632 y(the)e(v)-5 b(alues)31 b(of)h(\014elds,)h(and)f(the)g
+Fc(mo)l(di\014er-name)p Ff('s)h(up)r(date)f(them.)50
+b(The)32 b Fc(tag)g Ff(is)g(used)g(in)515 4732 y(prin)n(ting)24
+b(instances)g(of)g(the)h(record)e(t)n(yp)r(e)h(and)g(the)h(\014eld)g
+(tags)e(are)h(used)g(in)h(the)g(insp)r(ector)515 4832
+y(and)i(to)h(matc)n(h)f(constructor)f(argumen)n(ts)g(with)i(\014elds.)
+531 4981 y Fd(\017)41 b Fe(\(define-record-di)o(sc)o(los)o(er)35
+b Fc(typ)l(e)42 b(discloser)9 b Fe(\))1926 5255 y Ff(3)p
+eop
+%%Page: 4 4
+4 3 bop 515 523 a Fe(Define-record-di)o(sc)o(lo)o(ser)31
+b Ff(determines)37 b(ho)n(w)g(records)e(of)i(t)n(yp)r(e)h
+Fc(typ)l(e)g Ff(are)e(prin)n(ted.)515 623 y Fc(Discloser)41
+b Ff(should)f(b)r(e)h(pro)r(cedure)e(whic)n(h)h(tak)n(es)g(a)f(single)h
+(record)f(of)h(t)n(yp)r(e)h Fc(typ)l(e)f Ff(and)515 722
+y(returns)33 b(a)g(list)h(whose)f(car)f(is)i(a)f(sym)n(b)r(ol.)54
+b(The)34 b(record)e(will)i(b)r(e)g(prin)n(ted)f(as)g(the)h(v)-5
+b(alue)515 822 y(returned)27 b(b)n(y)g Fc(discloser)j
+Ff(with)e(curly)f(braces)f(used)i(instead)f(of)h(the)g(usual)f(paren)n
+(thesis.)639 922 y(F)-7 b(or)27 b(example)680 1076 y
+Fe(\(define-record-t)o(ype)37 b(pare)42 b(:pare)767 1175
+y(\(kons)g(x)h(y\))767 1275 y(pare?)767 1375 y(\(x)g(kar)f(set-kar!\))
+767 1474 y(\(y)h(kdr\)\))515 1629 y Ff(de\014nes)28 b
+Fe(kons)e Ff(to)h(b)r(e)i(a)e(constructor,)f Fe(kar)h
+Ff(and)h Fe(kdr)e Ff(to)i(b)r(e)g(accessors,)e Fe(set-kar!)34
+b Ff(to)28 b(b)r(e)515 1728 y(a)33 b(mo)r(di\014er,)j(and)e
+Fe(pare?)54 b Ff(to)34 b(b)r(e)h(a)e(predicate)h(for)f(a)h(new)g(t)n
+(yp)r(e)h(of)f(ob)5 b(ject.)56 b(The)34 b(t)n(yp)r(e)515
+1828 y(itself)28 b(is)f(named)h Fe(:pare)p Ff(.)35 b
+Fe(Pare)26 b Ff(is)h(a)g(tag)g(used)h(in)g(prin)n(ting)f(the)h(new)g
+(ob)5 b(jects.)639 1927 y(By)27 b(default,)h(the)f(new)g(ob)5
+b(jects)27 b(prin)n(t)g(as)f Fe(#Pare)p Ff(.)35 b(The)27
+b(prin)n(t)g(metho)r(d)h(can)f(b)r(e)g(mo)r(d-)515 2027
+y(i\014ed)h(using)f(DEFINE-RECORD-DISCLOSER:)680 2181
+y Fe(\(define-record-d)o(isc)o(lo)o(ser)37 b(:pare)767
+2281 y(\(lambda)k(\(p\))h(`\(pare)f(,\(kar)h(p\))h(,\(kdr)e(p\)\)\)\))
+515 2435 y Ff(will)28 b(cause)e(the)i(result)g(of)34
+b Fe(\(kons)41 b(1)i(2\))27 b Ff(to)h(prin)n(t)f(as)g
+Fe(#)p Fd(f)p Fe(pare)41 b(1)i(2)p Fd(g)p Ff(.)515 2707
+y Fg(5)134 b(Finite)46 b(record)f(t)l(yp)t(es)515 2889
+y Ff(The)31 b(structure)f Fe(finite-types)c Ff(has)k(t)n(w)n(o)g
+(macros)f(for)h(de\014ning)h(`\014nite')h(record)d(t)n(yp)r(es.)515
+2989 y(These)h(are)g(record)f(t)n(yp)r(es)i(for)f(whic)n(h)g(there)h
+(are)e(a)i(\014xed)f(n)n(um)n(b)r(er)h(of)f(instances,)h(whic)n(h)515
+3088 y(are)23 b(created)h(when)h(the)g(record)e(t)n(yp)r(e)h(is)h
+(de\014ned.)36 b(The)24 b(syn)n(tax)g(for)g(the)h(de\014ning)f(a)h
+(\014nite)515 3188 y(t)n(yp)r(e)j(is:)680 3342 y Fe(\(define-finite-t)o
+(ype)37 b Fc(tag)44 b(typ)l(e-name)767 3442 y Fe(\()p
+Fc(\014eld-tag)g Fe(...\))767 3541 y Fc(pr)l(e)l(dic)l(ate-name)767
+3641 y(ve)l(ctor-of-elements-name)767 3741 y(name-ac)l(c)l(essor)767
+3840 y(index-ac)l(c)l(essor)767 3940 y Fe(\()p Fc(\014eld-tag)g(ac)l(c)
+l(essor-name)g Fe([)p Fc(mo)l(di\014er-name)p Fe(]\))767
+4039 y(...)767 4139 y(\(\()p Fc(element-name)f(\014eld-value)h
+Fe(...\))811 4239 y(...\)\))515 4393 y Ff(This)27 b(di\013ers)h(from)f
+Fe(define-record-ty)o(pe)21 b Ff(in)28 b(the)g(follo)n(wing)f(w)n(a)n
+(ys:)639 4547 y Fd(\017)41 b Ff(No)32 b(name)g(is)h(sp)r(eci\014ed)f
+(for)g(the)h(constructor,)f(but)g(the)h(\014eld)g(argumen)n(ts)e(to)h
+(the)722 4647 y(constructor)26 b(are)h(listed.)639 4807
+y Fd(\017)41 b Ff(The)32 b Fc(ve)l(ctor-of-elements-name)g
+Ff(is)g(added;)h(it)g(will)e(b)r(e)i(b)r(ound)f(to)f(a)g(v)n(ector)g
+(con-)722 4907 y(taining)25 b(all)g(of)g(the)h(elemen)n(ts)f(of)g(the)h
+(t)n(yp)r(e.)36 b(These)25 b(are)f(constructed)h(b)n(y)g(applying)722
+5006 y(the)c(\(unnamed\))h(constructor)d(to)h(the)h(initial)g(\014eld)g
+(v)-5 b(alues)20 b(at)g(the)h(end)g(of)f(the)h(form.)1926
+5255 y(4)p eop
+%%Page: 5 5
+5 4 bop 639 523 a Fd(\017)41 b Ff(There)36 b(are)f(names)h(for)g
+(accessors)e(for)h(t)n(w)n(o)h(required)f(\014elds,)k(name)d(and)g
+(index.)722 623 y(These)28 b(\014elds)g(are)f(not)i(settable,)f(and)g
+(are)f(not)h(to)g(b)r(e)h(included)f(in)h(the)f(argumen)n(t)722
+722 y(list)g(for)f(the)h(constructor.)639 888 y Fd(\017)41
+b Ff(The)25 b(form)f(ends)h(with)g(the)g(names)f(and)g(the)h(initial)g
+(\014eld)g(v)-5 b(alues)24 b(for)g(the)h(elemen)n(ts)722
+988 y(of)31 b(the)g(t)n(yp)r(e.)47 b(The)31 b(name)f(m)n(ust)h(b)r(e)g
+(\014rst.)46 b(The)31 b(remaining)f(v)-5 b(alues)30 b(m)n(ust)h(matc)n
+(h)722 1088 y(the)d Fc(\014eld-tag)p Ff(s)g(in)g(the)g(constructor's)e
+(argumen)n(t)g(list.)639 1254 y Fd(\017)41 b Fc(T)-6
+b(ag)26 b Ff(is)e(b)r(ound)h(to)g(a)f(macro)g(that)h(maps)f
+Fc(element-name)p Ff(s)g(to)h(the)g(the)g(corresp)r(ond-)722
+1353 y(ing)31 b(elemen)n(t)f(of)h(the)g(v)n(ector.)44
+b(The)30 b(name)h(lo)r(okup)f(is)g(done)g(at)h(macro-expansion)722
+1453 y(time.)680 1636 y Fe(\(define-finite-t)o(ype)37
+b(color)k(:color)767 1735 y(\(red)h(green)g(blue\))767
+1835 y(color?)767 1934 y(colors)767 2034 y(color-name)767
+2134 y(color-index)767 2233 y(\(red)129 b(color-red\))767
+2333 y(\(green)41 b(color-green\))767 2433 y(\(blue)85
+b(color-blue\))767 2532 y(\(\(white)g(255)42 b(255)g(255\))811
+2632 y(\(black)172 b(0)130 b(0)g(0\))811 2731 y(\(yellow)41
+b(255)h(255)129 b(0\))811 2831 y(\(maroon)41 b(176)85
+b(48)i(96\)\)\))680 3030 y(\(color-name)39 b(\(vector-ref)g(colors)i
+(0\)\))i Fd(!)g Fe(white)680 3130 y(\(color-name)c(\(color)i(black\)\))
+390 b Fd(!)43 b Fe(black)680 3230 y(\(color-index)c(\(color)i
+(yellow\)\))302 b Fd(!)43 b Fe(2)680 3329 y(\(color-red)d(\(color)h
+(maroon\)\))389 b Fd(!)43 b Fe(176)639 3512 y Ff(En)n(umerated)32
+b(t)n(yp)r(es)g(are)g(\014nite)h(t)n(yp)r(es)g(whose)f(only)g(\014elds)
+h(are)f(the)h(name)f(and)h(the)515 3611 y(index.)k(The)27
+b(syn)n(tax)g(for)g(de\014ning)h(an)f(en)n(umerated)g(t)n(yp)r(e)h(is:)
+680 3778 y Fe(\(define-enumerat)o(ed-)o(ty)o(pe)37 b
+Fc(tag)44 b(typ)l(e-name)767 3877 y(pr)l(e)l(dic)l(ate-name)767
+3977 y(ve)l(ctor-of-elements-name)767 4076 y(name-ac)l(c)l(essor)767
+4176 y(index-ac)l(c)l(essor)767 4276 y Fe(\()p Fc(element-name)f
+Fe(...\)\))515 4442 y Ff(In)28 b(the)h(absence)f(of)h(an)n(y)e
+(additional)h(\014elds,)h(b)r(oth)g(the)g(constructor)e(argumen)n(t)g
+(list)i(and)515 4541 y(the)f(initial)g(\014eld)f(v)-5
+b(alues)28 b(are)e(not)i(required.)639 4641 y(The)41
+b(ab)r(o)n(v)n(e)d(example)i(of)g(a)g(\014nite)h(t)n(yp)r(e)f(can)g(b)r
+(e)g(pared)g(do)n(wn)g(to)g(the)g(follo)n(wing)515 4741
+y(en)n(umerated)27 b(t)n(yp)r(e:)1926 5255 y(5)p eop
+%%Page: 6 6
+6 5 bop 680 523 a Fe(\(define-enumerat)o(ed-)o(ty)o(pe)37
+b(color)42 b(:color)767 623 y(color?)767 722 y(colors)767
+822 y(color-name)767 922 y(color-index)767 1021 y(\(white)f(black)h
+(yellow)f(maroon\)\))680 1220 y(\(color-name)e(\(vector-ref)g(colors)i
+(0\)\))i Fd(!)g Fe(white)680 1320 y(\(color-name)c(\(color)i(black\)\))
+390 b Fd(!)43 b Fe(black)680 1420 y(\(color-index)c(\(color)i
+(yellow\)\))302 b Fd(!)43 b Fe(2)515 1694 y Fg(6)134
+b(Hash)46 b(tables)515 1876 y Ff(These)20 b(are)f(generic)g(hash)h
+(tables,)h(and)f(are)f(in)h(the)h(structure)f Fe(tables)p
+Ff(.)32 b(Strictly)20 b(sp)r(eaking)515 1975 y(they)32
+b(are)f(more)h(maps)f(than)i(tables,)g(as)e(ev)n(ery)g(table)h(has)g(a)
+g(v)-5 b(alue)32 b(for)g(ev)n(ery)e(p)r(ossible)515 2075
+y(k)n(ey)d(\(for)g(that)h(t)n(yp)r(e)g(of)f(table\).)37
+b(All)28 b(but)h(a)e(\014nite)h(n)n(um)n(b)r(er)f(of)h(those)f(v)-5
+b(alues)27 b(are)g Fe(#f)p Ff(.)531 2223 y Fd(\017)41
+b Fe(\(make-table\))c Fd(!)k Fc(table)531 2323 y Fd(\017)g
+Fe(\(make-symbol-tabl)o(e\))35 b Fd(!)42 b Fc(symb)l(ol-table)531
+2422 y Fd(\017)f Fe(\(make-string-tabl)o(e\))35 b Fd(!)42
+b Fc(string-table)531 2522 y Fd(\017)f Fe(\(make-integer-tab)o(le)o(\))
+36 b Fd(!)41 b Fc(inte)l(ger-table)531 2621 y Fd(\017)g
+Fe(\(make-table-maker)35 b Fc(c)l(omp)l(ar)l(e-pr)l(o)l(c)42
+b(hash-pr)l(o)l(c)5 b Fe(\))43 b Fd(!)e Fc(pr)l(o)l(c)l(e)l(dur)l(e)531
+2721 y Fd(\017)g Fe(\(make-table-immut)o(ab)o(le!)35
+b Fc(table)6 b Fe(\))515 2869 y Ff(The)37 b(\014rst)f(four)h(functions)
+g(listed)g(mak)n(e)f(v)-5 b(arious)36 b(kinds)h(of)g(tables.)64
+b Fe(Make-table)33 b Ff(re-)515 2969 y(turns)28 b(a)g(table)h(whose)e
+(k)n(eys)h(ma)n(y)g(b)r(e)h(sym)n(b)r(ols,)f(in)n(teger,)g(c)n
+(haracters,)e(b)r(o)r(oleans,)i(or)g(the)515 3068 y(empt)n(y)e(list)g
+(\(these)g(are)f(also)g(the)h(v)-5 b(alues)26 b(that)g(ma)n(y)f(b)r(e)i
+(used)f(in)g Fe(case)e Ff(expressions\).)35 b(As)515
+3168 y(with)27 b Fe(case)p Ff(,)e(comparison)g(is)i(done)f(using)h
+Fe(eqv?)p Ff(.)35 b(The)27 b(comparison)e(pro)r(cedures)g(used)i(in)515
+3267 y(sym)n(b)r(ol,)g(string,)g(and)g(in)n(teger)g(tables)g(are)g
+Fe(eq?)p Ff(,)f Fe(string=?)p Ff(,)f(and)i Fe(=)p Ff(.)639
+3367 y Fe(Make-table-maker)16 b Ff(tak)n(es)21 b(t)n(w)n(o)g(pro)r
+(cedures)g(as)g(argumen)n(ts)f(and)i(returns)g(a)f(n)n(ullary)515
+3467 y(table-making)d(pro)r(cedure.)33 b Fc(Comp)l(ar)l(e-pr)l(o)l(c)21
+b Ff(should)f(b)r(e)g(a)f(t)n(w)n(o-argumen)n(t)e(equalit)n(y)i(pred-)
+515 3566 y(icate.)68 b Fc(Hash-pr)l(o)l(c)39 b Ff(should)e(b)r(e)i(a)e
+(one)h(argumen)n(t)f(pro)r(cedure)g(that)h(tak)n(es)f(a)h(k)n(ey)f(and)
+515 3666 y(returns)27 b(a)g(non-negativ)n(e)f(in)n(teger)h(hash)h(v)-5
+b(alue.)37 b(If)e Fe(\()p Fc(c)l(omp)l(ar)l(e-pr)l(o)l(c)44
+b(x)f(y)p Fe(\))28 b Ff(returns)f(true,)515 3766 y(then)39
+b Fe(\(=)k(\()p Fc(hash-pr)l(o)l(c)i(x)p Fe(\))e(\()p
+Fc(hash-pr)l(o)l(c)h(y)p Fe(\)\))39 b Ff(m)n(ust)g(also)f(return)h
+(true.)72 b(F)-7 b(or)38 b(example,)515 3865 y Fe(make-integer-tab)o
+(le)21 b Ff(could)27 b(b)r(e)h(de\014ned)g(as)f Fe(\(make-table-maker)
+37 b(=)43 b(abs\))p Ff(.)639 3965 y Fe(Make-table-immuta)o(bl)o(e!)30
+b Ff(prohibits)e(future)g(mo)r(di\014cation)f(to)h(its)f(argumen)n(t.)
+531 4113 y Fd(\017)41 b Fe(\(table?)47 b Fc(value)6 b
+Fe(\))42 b Fd(!)g Fc(b)l(o)l(ole)l(an)531 4212 y Fd(\017)f
+Fe(\(table-ref)d Fc(table)k(key)7 b Fe(\))42 b Fd(!)g
+Fc(value)g(or)g Fa(#f)531 4312 y Fd(\017)f Fe(\(table-set!)c
+Fc(table)42 b(key)h(value)6 b Fe(\))531 4412 y Fd(\017)41
+b Fe(\(table-walk)c Fc(pr)l(o)l(c)l(e)l(dur)l(e)42 b(table)6
+b Fe(\))515 4559 y(Table?)62 b Ff(is)36 b(the)h(predicate)g(for)f
+(tables.)64 b Fe(Table-ref)33 b Ff(and)j Fe(table-set!)61
+b Ff(access)35 b(and)515 4659 y(mo)r(dify)i(the)g(v)-5
+b(alue)37 b(of)g Fc(key)g Ff(in)g Fc(table)p Ff(.)66
+b Fe(Table-walk)32 b Ff(applies)37 b Fc(pr)l(o)l(c)l(e)l(dur)l(e)p
+Ff(,)i(whic)n(h)e(m)n(ust)515 4759 y(accept)27 b(t)n(w)n(o)g(argumen)n
+(ts,)f(to)i(ev)n(ery)e(asso)r(ciated)g(k)n(ey)h(and)h(non-)p
+Fe(#f)e Ff(v)-5 b(alue)27 b(in)h Fe(table)p Ff(.)531
+4907 y Fd(\017)41 b Fe(\(default-hash-fun)o(ct)o(ion)35
+b Fc(value)6 b Fe(\))42 b Fd(!)f Fc(inte)l(ger)531 5006
+y Fd(\017)g Fe(\(string-hash)c Fc(string)7 b Fe(\))41
+b Fd(!)h Fc(inte)l(ger)1926 5255 y Ff(6)p eop
+%%Page: 7 7
+7 6 bop 515 523 a Fe(default-hash-fun)o(ct)o(io)o(n)30
+b Ff(is)35 b(the)h(hash)g(function)g(used)g(in)g(the)g(tables)f
+(returned)g(b)n(y)515 623 y Fe(make-table)p Ff(,)23 b(and)28
+b Fe(string-hash)23 b Ff(it)28 b(the)g(one)f(used)h(b)n(y)g
+Fe(make-string-table)o Ff(.)1926 5255 y(7)p eop
+%%Trailer
+end
+userdict /end-hook known{end-hook}if
+%%EOF
diff --git a/emacs/README b/emacs/README
new file mode 100644
index 0000000..02079d7
--- /dev/null
+++ b/emacs/README
@@ -0,0 +1,47 @@
+Date: Thu, 9 Jul 92 13:26:05 HKT
+From: shivers@csd.hku.hk (Olin G. Shivers)
+To: jar@cs.cornell.edu
+In-Reply-To: Jonathan Rees's message of Wed, 8 Jul 92 22:15:22 -0400 <9207090215.AA00991@sindri.cs.cornell.edu>
+Subject: cmulisp
+
+It's also in Ozan's repository, but I don't know how up-to-date it is.
+It's always useful to list his repository as a possible location, tho.
+	-Olin
+
+/afs/cs.cmu.edu/user/shivers/lib/Readme:
+This directory contains the following subdirectories:
+    emacs   Gnu emacs packages.
+    papers  My papers, in .dvi and postscript form.
+    tex     LaTeX packages.
+All of these files can be anonymously ftp'd.
+    -Olin
+     July 3, 1991
+
+===============================================================================
+Directions for anonymous ftp:
+1. ftp to any CMU machine with access to the /afs network file system.
+   Almost any machine will do; some possibilities are:
+    	cs.cmu.edu  	    128.2.222.173
+    	a.gp.cs.cmu.edu	    128.2.242.7
+    	f.gp.cs.cmu.edu	    128.2.250.164
+    	h.gp.cs.cmu.edu	    128.2.254.156
+    	k.gp.cs.cmu.edu	    128.2.254.137
+
+2. login as anonymous
+   You are supposed to provide username@host as the password. The CMU
+   ftp demon actually checks to ensure there's an "@" in the password.
+   So you can't just say "foo"; you have to say "foo@bar".
+
+3. cd /afs/cs.cmu.edu/user/shivers/lib
+   CMU ftp restricts the directories you can access anonymously,
+   so you must cd straight to the .../lib directory or its descendants.
+4. If you are transfering .dvi or other binary files, set the file transfer
+   mode to raw binary with one of the following commands:
+        type image
+    	type binary
+    	image
+    	binary
+   If you don't do this, the files may be garbled.
+5. Use dir or ls to list the directory.
+6. Transfer the files you want.
+
diff --git a/emacs/cmulisp.el b/emacs/cmulisp.el
new file mode 100644
index 0000000..b15fa07
--- /dev/null
+++ b/emacs/cmulisp.el
@@ -0,0 +1,693 @@
+;;; -*-Emacs-Lisp-*- cmulisp.el
+;;; Copyright Olin Shivers (1988).
+;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright
+;;; notice appearing here to the effect that you may use this code any
+;;; way you like, as long as you don't charge money for it, remove this
+;;; notice, or hold me liable for its results.
+
+;;; This replaces the standard inferior-lisp mode.
+;;; Hacked from tea.el by Olin Shivers (shivers@cs.cmu.edu). 8/88
+;;; Please send me bug reports, bug fixes, and extensions, so that I can
+;;; merge them into the master source.
+;;;
+;;; Change log at end of file.
+
+;;; This file defines a a lisp-in-a-buffer package (cmulisp mode) built on top
+;;; of comint mode.  Cmulisp mode is similar to, and intended to replace, its
+;;; counterpart in the standard gnu emacs release. This replacements is more
+;;; featureful, robust, and uniform than the released version.  The key
+;;; bindings are also more compatible with the bindings of Hemlock and Zwei
+;;; (the Lisp Machine emacs).
+
+;;; Since this mode is built on top of the general command-interpreter-in-
+;;; a-buffer mode (comint mode), it shares a common base functionality, 
+;;; and a common set of bindings, with all modes derived from comint mode.
+;;; This makes these modes easier to use.
+
+;;; For documentation on the functionality provided by comint mode, and
+;;; the hooks available for customising it, see the file comint.el.
+;;; For further information on cmulisp mode, see the comments below.
+
+;;; Needs fixin:
+;;; The load-file/compile-file default mechanism could be smarter -- it
+;;; doesn't know about the relationship between filename extensions and
+;;; whether the file is source or executable. If you compile foo.lisp
+;;; with compile-file, then the next load-file should use foo.bin for
+;;; the default, not foo.lisp. This is tricky to do right, particularly
+;;; because the extension for executable files varies so much (.o, .bin,
+;;; .lbin, .mo, .vo, .ao, ...).
+;;;
+;;; It would be nice if cmulisp (and inferior scheme, T, ...) modes
+;;; had a verbose minor mode wherein sending or compiling defuns, etc.
+;;; would be reflected in the transcript with suitable comments, e.g.
+;;; ";;; redefining fact". Several ways to do this. Which is right?
+;;;
+;;; When sending text from a source file to a subprocess, the process-mark can 
+;;; move off the window, so you can lose sight of the process interactions.
+;;; Maybe I should ensure the process mark is in the window when I send
+;;; text to the process? Switch selectable?
+
+(require 'comint)
+
+;; YOUR .EMACS FILE
+;;=============================================================================
+;; Some suggestions for your .emacs file.
+;;
+;; ; If cmulisp lives in some non-standard directory, you must tell emacs
+;; ; where to get it. This may or may not be necessary.
+;; (setq load-path (cons (expand-file-name "~jones/lib/emacs") load-path))
+;;
+;; ; Autoload cmulisp from file cmulisp.el
+;; (autoload 'cmulisp "cmulisp"
+;;           "Run an inferior Lisp process."
+;;           t)
+;;
+;; ; Define C-c t to run my favorite command in cmulisp mode:
+;; (setq cmulisp-load-hook
+;;       '((lambda () 
+;;           (define-key cmulisp-mode-map "\C-ct" 'favorite-cmd))))
+
+
+;;; Brief Command Documentation:
+;;;============================================================================
+;;; Comint Mode Commands: (common to cmulisp and all comint-derived modes)
+;;;
+;;; m-p	    comint-previous-input    	    Cycle backwards in input history
+;;; m-n	    comint-next-input  	    	    Cycle forwards
+;;; m-c-r   comint-previous-input-matching  Search backwards in input history
+;;; return  comint-send-input
+;;; c-a     comint-bol                      Beginning of line; skip prompt.
+;;; c-d	    comint-delchar-or-maybe-eof	    Delete char unless at end of buff.
+;;; c-c c-u comint-kill-input	    	    ^u
+;;; c-c c-w backward-kill-word    	    ^w
+;;; c-c c-c comint-interrupt-subjob 	    ^c
+;;; c-c c-z comint-stop-subjob	    	    ^z
+;;; c-c c-\ comint-quit-subjob	    	    ^\
+;;; c-c c-o comint-kill-output		    Delete last batch of process output
+;;; c-c c-r comint-show-output		    Show last batch of process output
+;;;         send-invisible                  Read line w/o echo & send to proc
+;;;         comint-continue-subjob	    Useful if you accidentally suspend
+;;;					        top-level job.
+;;; comint-mode-hook is the comint mode hook.
+
+;;; CMU Lisp Mode Commands:
+;;; c-m-x   lisp-send-defun     This binding is a gnu convention.
+;;; c-c c-l lisp-load-file  	Prompt for file name; tell Lisp to load it.
+;;; c-c c-k lisp-compile-file	Prompt for file name; tell Lisp to kompile it.
+;;; 	    	    	    	Filename completion is available, of course.
+;;;
+;;; Additionally, these commands are added to the key bindings of Lisp mode:
+;;; c-m-x   lisp-eval-defun         This binding is a gnu convention.
+;;; c-c c-e lisp-eval-defun 	    Send the current defun to Lisp process.
+;;; c-x c-e lisp-eval-last-sexp     Send the previous sexp to Lisp process.
+;;; c-c c-r lisp-eval-region        Send the current region to Lisp process.
+;;; c-c c-c lisp-compile-defun      Compile the current defun in Lisp process.
+;;; c-c c-z switch-to-lisp          Switch to the Lisp process buffer.
+;;; c-c c-l lisp-load-file          (See above. In a Lisp file buffer, default
+;;; c-c c-k lisp-compile-file        is to load/compile the current file.)
+;;; c-c c-d lisp-describe-sym	    Query Lisp for a symbol's description.
+;;; c-c c-a lisp-show-arglist	    Query Lisp for function's arglist.
+;;; c-c c-f lisp-show-function-documentation Query Lisp for a function's doc.
+;;; c-c c-v lisp-show-variable-documentation Query Lisp for a variable's doc.
+
+;;; cmulisp	    	    	    Fires up the Lisp process.
+;;; lisp-compile-region     	    Compile all forms in the current region.
+;;;
+;;; CMU Lisp Mode Variables:
+;;; cmulisp-filter-regexp	    Match this => don't get saved on input hist
+;;; inferior-lisp-program   	    Name of Lisp program run-lisp executes
+;;; inferior-lisp-load-command	    Customises lisp-load-file
+;;; cmulisp-mode-hook  	    
+;;; inferior-lisp-prompt	    Initialises comint-prompt-regexp.
+;;;				    Backwards compatibility.
+;;; lisp-source-modes               Anything loaded into a buffer that's in
+;;;                                 one of these modes is considered Lisp 
+;;;                                 source by lisp-load/compile-file.
+
+;;; Read the rest of this file for more information.
+
+(defvar cmulisp-filter-regexp "\\`\\s *\\(:\\(\\w\\|\\s_\\)\\)?\\s *\\'"
+  "*What not to save on inferior Lisp's input history
+Input matching this regexp is not saved on the input history in cmulisp
+mode. Default is whitespace followed by 0 or 1 single-letter :keyword 
+(as in :a, :c, etc.)")
+
+(defvar cmulisp-mode-map nil)
+(cond ((not cmulisp-mode-map)
+       (setq cmulisp-mode-map
+	     (copy-keymap comint-mode-map))
+       (lisp-mode-commands cmulisp-mode-map)
+       (define-key cmulisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp)
+       (define-key cmulisp-mode-map "\C-c\C-l" 'lisp-load-file)
+       (define-key cmulisp-mode-map "\C-c\C-k" 'lisp-compile-file)
+       (define-key cmulisp-mode-map "\C-c\C-a" 'lisp-show-arglist)
+       (define-key cmulisp-mode-map "\C-c\C-d" 'lisp-describe-sym)
+       (define-key cmulisp-mode-map "\C-c\C-f" 'lisp-show-function-documentation)
+       (define-key cmulisp-mode-map "\C-c\C-v" 'lisp-show-variable-documentation)))
+
+;;; These commands augment Lisp mode, so you can process Lisp code in
+;;; the source files.
+(define-key lisp-mode-map "\M-\C-x"  'lisp-eval-defun)     ; Gnu convention
+(define-key lisp-mode-map "\C-x\C-e" 'lisp-eval-last-sexp) ; Gnu convention
+(define-key lisp-mode-map "\C-c\C-e" 'lisp-eval-defun)
+(define-key lisp-mode-map "\C-c\C-r" 'lisp-eval-region)
+(define-key lisp-mode-map "\C-c\C-c" 'lisp-compile-defun)
+(define-key lisp-mode-map "\C-c\C-z" 'switch-to-lisp)
+(define-key lisp-mode-map "\C-c\C-l" 'lisp-load-file)
+(define-key lisp-mode-map "\C-c\C-k" 'lisp-compile-file)  ; "kompile" file
+(define-key lisp-mode-map "\C-c\C-a" 'lisp-show-arglist)
+(define-key lisp-mode-map "\C-c\C-d" 'lisp-describe-sym)
+(define-key lisp-mode-map "\C-c\C-f" 'lisp-show-function-documentation)
+(define-key lisp-mode-map "\C-c\C-v" 'lisp-show-variable-documentation)
+
+
+;;; This function exists for backwards compatibility.
+;;; Previous versions of this package bound commands to C-c <letter>
+;;; bindings, which is not allowed by the gnumacs standard.
+
+(defun cmulisp-install-letter-bindings ()
+  "This function binds many cmulisp commands to C-c <letter> bindings,
+where they are more accessible. C-c <letter> bindings are reserved for the
+user, so these bindings are non-standard. If you want them, you should
+have this function called by the cmulisp-load-hook:
+    (setq cmulisp-load-hook '(cmulisp-install-letter-bindings))
+You can modify this function to install just the bindings you want."
+
+  (define-key lisp-mode-map "\C-ce" 'lisp-eval-defun-and-go)
+  (define-key lisp-mode-map "\C-cr" 'lisp-eval-region-and-go)
+  (define-key lisp-mode-map "\C-cc" 'lisp-compile-defun-and-go)
+  (define-key lisp-mode-map "\C-cz" 'switch-to-lisp)
+  (define-key lisp-mode-map "\C-cl" 'lisp-load-file)
+  (define-key lisp-mode-map "\C-ck" 'lisp-compile-file)
+  (define-key lisp-mode-map "\C-ca" 'lisp-show-arglist)
+  (define-key lisp-mode-map "\C-cd" 'lisp-describe-sym)
+  (define-key lisp-mode-map "\C-cf" 'lisp-show-function-documentation)
+  (define-key lisp-mode-map "\C-cv" 'lisp-show-variable-documentation)
+
+  (define-key cmulisp-mode-map "\C-cl" 'lisp-load-file)
+  (define-key cmulisp-mode-map "\C-ck" 'lisp-compile-file)
+  (define-key cmulisp-mode-map "\C-ca" 'lisp-show-arglist)
+  (define-key cmulisp-mode-map "\C-cd" 'lisp-describe-sym)
+  (define-key cmulisp-mode-map "\C-cf" 'lisp-show-function-documentation)
+  (define-key cmulisp-mode-map "\C-cv" 'lisp-show-variable-documentation))
+
+
+(defvar inferior-lisp-program "lisp"
+  "*Program name for invoking an inferior Lisp with `cmulisp'.")
+
+(defvar inferior-lisp-load-command "(load \"%s\")\n"
+  "*Format-string for building a Lisp expression to load a file.
+This format string should use %s to substitute a file name
+and should result in a Lisp expression that will command the inferior Lisp
+to load that file.  The default works acceptably on most Lisps.
+The string \"(progn (load \\\"%s\\\" :verbose nil :print t) (values))\\\n\"
+produces cosmetically superior output for this application,
+but it works only in Common Lisp.")
+
+(defvar inferior-lisp-prompt "^[^> ]*>+:? *"
+  "Regexp to recognise prompts in the inferior Lisp.
+Defaults to \"^[^> ]*>+:? *\", which works pretty good for Lucid, kcl,
+and franz. This variable is used to initialise comint-prompt-regexp in the 
+cmulisp buffer.
+
+More precise choices:
+Lucid Common Lisp: \"^\\(>\\|\\(->\\)+\\) *\"
+franz: \"^\\(->\\|<[0-9]*>:\\) *\"
+kcl: \"^>+ *\"
+
+This is a fine thing to set in your .emacs file.")
+
+(defvar cmulisp-mode-hook '()
+  "*Hook for customising cmulisp mode")
+
+(defun cmulisp-mode () 
+  "Major mode for interacting with an inferior Lisp process.  
+Runs a Lisp interpreter as a subprocess of Emacs, with Lisp I/O through an
+Emacs buffer.  Variable inferior-lisp-program controls which Lisp interpreter
+is run.  Variables inferior-lisp-prompt, cmulisp-filter-regexp and
+inferior-lisp-load-command can customize this mode for different Lisp
+interpreters.
+
+For information on running multiple processes in multiple buffers, see
+documentation for variable cmulisp-buffer.
+
+\\{cmulisp-mode-map}
+
+Customisation: Entry to this mode runs the hooks on comint-mode-hook and
+cmulisp-mode-hook (in that order).
+
+You can send text to the inferior Lisp process from other buffers containing
+Lisp source.  
+    switch-to-lisp switches the current buffer to the Lisp process buffer.
+    lisp-eval-defun sends the current defun to the Lisp process.
+    lisp-compile-defun compiles the current defun.
+    lisp-eval-region sends the current region to the Lisp process.
+    lisp-compile-region compiles the current region.
+
+    Prefixing the lisp-eval/compile-defun/region commands with
+    a \\[universal-argument] causes a switch to the Lisp process buffer after sending
+    the text.
+
+Commands:
+Return after the end of the process' output sends the text from the 
+    end of process to point.
+Return before the end of the process' output copies the sexp ending at point
+    to the end of the process' output, and sends it.
+Delete converts tabs to spaces as it moves back.
+Tab indents for Lisp; with argument, shifts rest
+    of expression rigidly with the current line.
+C-M-q does Tab on each line starting within following expression.
+Paragraphs are separated only by blank lines.  Semicolons start comments.
+If you accidentally suspend your process, use \\[comint-continue-subjob]
+to continue it."
+  (interactive)
+  (kill-all-local-variables)
+  (comint-mode)
+  (setq comint-prompt-regexp inferior-lisp-prompt)
+  (setq major-mode 'cmulisp-mode)
+  (setq mode-name "CMU Lisp")
+  (setq mode-line-process '(": %s"))
+  (if (string-match "^18.4" emacs-version) ; hack.
+      (lisp-mode-variables)    ; This is right for 18.49  
+      (lisp-mode-variables t)) ; This is right for 18.50
+  (use-local-map cmulisp-mode-map)    ;c-c c-k for "kompile" file
+  (setq comint-get-old-input (function lisp-get-old-input))
+  (setq comint-input-filter (function lisp-input-filter))
+  (setq comint-input-sentinel 'ignore)
+  (run-hooks 'cmulisp-mode-hook))
+
+(defun lisp-get-old-input ()
+  "Snarf the sexp ending at point"
+  (save-excursion
+    (let ((end (point)))
+      (backward-sexp)
+      (buffer-substring (point) end))))
+
+(defun lisp-input-filter (str)
+  "Don't save anything matching cmulisp-filter-regexp"
+  (not (string-match cmulisp-filter-regexp str)))
+
+(defun cmulisp (&optional cmd)
+  "Run an inferior Lisp process, input and output via buffer *cmulisp*.
+If there is a process already running in *cmulisp*, just switch to that buffer.
+With argument, allows you to edit the command line (default is value
+of inferior-lisp-program).  Runs the hooks from cmulisp-mode-hook (after the
+comint-mode-hook is run).
+\(Type \\[describe-mode] in the process buffer for a list of commands.)"
+  (interactive (list (and current-prefix-arg
+			  (read-string "Run lisp: " inferior-lisp-program))))
+  (let ((cmd (or cmd inferior-lisp-program)))
+    (if (not (comint-check-proc "*cmulisp*"))
+	(let ((cmdlist (cmulisp-args-to-list cmd)))
+	  (set-buffer (apply (function make-comint) "cmulisp" (car cmdlist) nil
+			     (cdr cmdlist)))
+	  (cmulisp-mode))))
+  (setq cmulisp-buffer "*cmulisp*")
+  (switch-to-buffer "*cmulisp*"))
+
+;;; Break a string up into a list of arguments.
+;;; This will break if you have an argument with whitespace, as in
+;;; string = "-ab +c -x 'you lose'".
+(defun cmulisp-args-to-list (string)
+  (let ((where (string-match "[ \t]" string)))
+    (cond ((null where) (list string))
+	  ((not (= where 0))
+	   (cons (substring string 0 where)
+		 (cmulisp-args-to-list (substring string (+ 1 where)
+						  (length string)))))
+	  (t (let ((pos (string-match "[^ \t]" string)))
+	       (if (null pos)
+		   nil
+		 (cmulisp-args-to-list (substring string pos
+						  (length string)))))))))
+
+(defun lisp-eval-region (start end &optional and-go)
+  "Send the current region to the inferior Lisp process.
+Prefix argument means switch-to-lisp afterwards."
+  (interactive "r\nP")
+  (comint-send-region (cmulisp-proc) start end)
+  (comint-send-string (cmulisp-proc) "\n")
+  (if and-go (switch-to-lisp t)))
+
+(defun lisp-eval-defun (&optional and-go)
+  "Send the current defun to the inferior Lisp process.
+Prefix argument means switch-to-lisp afterwards."
+  (interactive "P")
+  (save-excursion
+    (end-of-defun)
+    (skip-chars-backward " \t\n\r\f") ;  Makes allegro happy
+    (let ((end (point)))
+      (beginning-of-defun)
+      (lisp-eval-region (point) end)))
+  (if and-go (switch-to-lisp t)))
+
+(defun lisp-eval-last-sexp (&optional and-go)
+  "Send the previous sexp to the inferior Lisp process.
+Prefix argument means switch-to-lisp afterwards."
+  (interactive "P")
+  (lisp-eval-region (save-excursion (backward-sexp) (point)) (point) and-go))
+
+;;; Common Lisp COMPILE sux. 
+(defun lisp-compile-region (start end &optional and-go)
+  "Compile the current region in the inferior Lisp process.
+Prefix argument means switch-to-lisp afterwards."
+  (interactive "r\nP")
+  (comint-send-string (cmulisp-proc)
+    (format "(funcall (compile nil `(lambda () (progn 'compile %s))))\n"
+	    (buffer-substring start end)))
+  (if and-go (switch-to-lisp t)))
+			 
+(defun lisp-compile-defun (&optional and-go)
+  "Compile the current defun in the inferior Lisp process.
+Prefix argument means switch-to-lisp afterwards."
+  (interactive "P")
+  (save-excursion
+    (end-of-defun)
+    (skip-chars-backward " \t\n\r\f") ;  Makes allegro happy
+    (let ((e (point)))
+      (beginning-of-defun)
+      (lisp-compile-region (point) e)))
+  (if and-go (switch-to-lisp t)))
+
+(defun switch-to-lisp (eob-p)
+  "Switch to the inferior Lisp process buffer.
+With argument, positions cursor at end of buffer."
+  (interactive "P")
+  (if (get-buffer cmulisp-buffer)
+      (pop-to-buffer cmulisp-buffer)
+      (error "No current process buffer. See variable cmulisp-buffer."))
+  (cond (eob-p
+	 (push-mark)
+	 (goto-char (point-max)))))
+
+
+;;; Now that lisp-compile/eval-defun/region takes an optional prefix arg,
+;;; these commands are redundant. But they are kept around for the user
+;;; to bind if he wishes, for backwards functionality, and because it's
+;;; easier to type C-c e than C-u C-c C-e.
+
+(defun lisp-eval-region-and-go (start end)
+  "Send the current region to the inferior Lisp, 
+and switch to the process buffer."
+  (interactive "r")
+  (lisp-eval-region start end t))
+
+(defun lisp-eval-defun-and-go ()
+  "Send the current defun to the inferior Lisp, 
+and switch to the process buffer."
+  (interactive)
+  (lisp-eval-defun t))
+
+(defun lisp-compile-region-and-go (start end)
+  "Compile the current region in the inferior Lisp, 
+and switch to the process buffer."
+  (interactive "r")
+  (lisp-compile-region start end t))
+
+(defun lisp-compile-defun-and-go ()
+  "Compile the current defun in the inferior Lisp, 
+and switch to the process buffer."
+  (interactive)
+  (lisp-compile-defun t))
+
+;;; A version of the form in H. Shevis' soar-mode.el package. Less robust.
+;(defun lisp-compile-sexp (start end)
+;  "Compile the s-expression bounded by START and END in the inferior lisp.
+;If the sexp isn't a DEFUN form, it is evaluated instead."
+;    (cond ((looking-at "(defun\\s +")
+;	   (goto-char (match-end 0))
+;	   (let ((name-start (point)))
+;	     (forward-sexp 1)
+;	     (process-send-string "cmulisp" (format "(compile '%s #'(lambda "
+;						 (buffer-substring name-start
+;								   (point)))))
+;	   (let ((body-start (point)))
+;	     (goto-char start) (forward-sexp 1) ; Can't use end-of-defun.
+;	     (process-send-region "cmulisp" (buffer-substring body-start (point))))
+;	   (process-send-string "cmulisp" ")\n"))
+;	  (t (lisp-eval-region start end)))))
+;
+;(defun lisp-compile-region (start end)
+;  "Each s-expression in the current region is compiled (if a DEFUN)
+;or evaluated (if not) in the inferior lisp."
+;  (interactive "r")
+;  (save-excursion
+;    (goto-char start) (end-of-defun) (beginning-of-defun) ; error check
+;    (if (< (point) start) (error "region begins in middle of defun"))
+;    (goto-char start)
+;    (let ((s start))
+;      (end-of-defun)
+;      (while (<= (point) end) ; Zip through
+;	(lisp-compile-sexp s (point)) ; compiling up defun-sized chunks.
+;	(setq s (point))
+;	(end-of-defun))
+;      (if (< s end) (lisp-compile-sexp s end)))))
+;;;
+;;; End of HS-style code
+
+
+(defvar lisp-prev-l/c-dir/file nil
+  "Saves the (directory . file) pair used in the last lisp-load-file or
+lisp-compile-file command. Used for determining the default in the 
+next one.")
+
+(defvar lisp-source-modes '(lisp-mode)
+  "*Used to determine if a buffer contains Lisp source code.
+If it's loaded into a buffer that is in one of these major modes, it's
+considered a Lisp source file by lisp-load-file and lisp-compile-file.
+Used by these commands to determine defaults.")
+
+(defun lisp-load-file (file-name)
+  "Load a Lisp file into the inferior Lisp process."
+  (interactive (comint-get-source "Load Lisp file: " lisp-prev-l/c-dir/file
+				  lisp-source-modes nil)) ; NIL because LOAD
+                                                   ; doesn't need an exact name
+  (comint-check-source file-name) ; Check to see if buffer needs saved.
+  (setq lisp-prev-l/c-dir/file (cons (file-name-directory    file-name)
+				     (file-name-nondirectory file-name)))
+  (comint-send-string (cmulisp-proc)
+		      (format inferior-lisp-load-command file-name))
+  (switch-to-lisp t))
+
+
+(defun lisp-compile-file (file-name)
+  "Compile a Lisp file in the inferior Lisp process."
+  (interactive (comint-get-source "Compile Lisp file: " lisp-prev-l/c-dir/file
+				  lisp-source-modes nil)) ; NIL = don't need
+                                                          ; suffix .lisp
+  (comint-check-source file-name) ; Check to see if buffer needs saved.
+  (setq lisp-prev-l/c-dir/file (cons (file-name-directory    file-name)
+				     (file-name-nondirectory file-name)))
+  (comint-send-string (cmulisp-proc) (concat "(compile-file \""
+					     file-name
+					     "\"\)\n"))
+  (switch-to-lisp t))
+
+
+
+;;; Documentation functions: function doc, var doc, arglist, and
+;;; describe symbol.
+;;; ===========================================================================
+
+;;; Command strings
+;;; ===============
+
+(defvar lisp-function-doc-command
+  "(let ((fn '%s))
+     (format t \"Documentation for ~a:~&~a\"
+	     fn (documentation fn 'function))
+     (values))\n"
+  "Command to query inferior Lisp for a function's documentation.")
+
+(defvar lisp-var-doc-command
+  "(let ((v '%s))
+     (format t \"Documentation for ~a:~&~a\"
+	     v (documentation v 'variable))
+     (values))\n"
+  "Command to query inferior Lisp for a variable's documentation.")
+
+(defvar lisp-arglist-command
+  "(let ((fn '%s))
+     (format t \"Arglist for ~a: ~a\" fn (arglist fn))
+     (values))\n"
+  "Command to query inferior Lisp for a function's arglist.")
+
+(defvar lisp-describe-sym-command
+  "(describe '%s)\n"
+  "Command to query inferior Lisp for a variable's documentation.")
+
+
+;;; Ancillary functions
+;;; ===================
+
+;;; Reads a string from the user.
+(defun lisp-symprompt (prompt default)
+  (list (let* ((prompt (if default
+			   (format "%s (default %s): " prompt default)
+			   (concat prompt ": ")))
+	       (ans (read-string prompt)))
+	  (if (zerop (length ans)) default ans))))
+
+
+;;; Adapted from function-called-at-point in help.el.
+(defun lisp-fn-called-at-pt ()
+  "Returns the name of the function called in the current call.
+Nil if it can't find one."
+  (condition-case nil
+      (save-excursion
+	(save-restriction
+	  (narrow-to-region (max (point-min) (- (point) 1000)) (point-max))
+	  (backward-up-list 1)
+	  (forward-char 1)
+	  (let ((obj (read (current-buffer))))
+	    (and (symbolp obj) obj))))
+    (error nil)))
+
+
+;;; Adapted from variable-at-point in help.el.
+(defun lisp-var-at-pt ()
+  (condition-case ()
+      (save-excursion
+	(forward-sexp -1)
+	(skip-chars-forward "'")
+	(let ((obj (read (current-buffer))))
+	  (and (symbolp obj) obj)))
+    (error nil)))
+
+
+;;; Documentation functions: fn and var doc, arglist, and symbol describe.
+;;; ======================================================================
+
+(defun lisp-show-function-documentation (fn)
+  "Send a command to the inferior Lisp to give documentation for function FN.
+See variable lisp-function-doc-command."
+  (interactive (lisp-symprompt "Function doc" (lisp-fn-called-at-pt)))
+  (comint-proc-query (cmulisp-proc) (format lisp-function-doc-command fn)))
+
+(defun lisp-show-variable-documentation (var)
+  "Send a command to the inferior Lisp to give documentation for function FN.
+See variable lisp-var-doc-command."
+  (interactive (lisp-symprompt "Variable doc" (lisp-var-at-pt)))
+  (comint-proc-query (cmulisp-proc) (format lisp-var-doc-command var)))
+
+(defun lisp-show-arglist (fn)
+  "Sends an query to the inferior Lisp for the arglist for function FN.
+See variable lisp-arglist-command."
+  (interactive (lisp-symprompt "Arglist" (lisp-fn-called-at-pt)))
+  (comint-proc-query (cmulisp-proc) (format lisp-arglist-command fn)))
+
+(defun lisp-describe-sym (sym)
+  "Send a command to the inferior Lisp to describe symbol SYM.
+See variable lisp-describe-sym-command."
+  (interactive (lisp-symprompt "Describe" (lisp-var-at-pt)))
+  (comint-proc-query (cmulisp-proc) (format lisp-describe-sym-command sym)))
+
+
+(defvar cmulisp-buffer nil "*The current cmulisp process buffer.
+
+MULTIPLE PROCESS SUPPORT
+===========================================================================
+Cmulisp.el supports, in a fairly simple fashion, running multiple Lisp
+processes. To run multiple Lisp processes, you start the first up with
+\\[cmulisp]. It will be in a buffer named *cmulisp*. Rename this buffer
+with \\[rename-buffer]. You may now start up a new process with another
+\\[cmulisp]. It will be in a new buffer, named *cmulisp*. You can
+switch between the different process buffers with \\[switch-to-buffer].
+
+Commands that send text from source buffers to Lisp processes --
+like lisp-eval-defun or lisp-show-arglist -- have to choose a process
+to send to, when you have more than one Lisp process around. This
+is determined by the global variable cmulisp-buffer. Suppose you
+have three inferior lisps running:
+    Buffer	Process
+    foo		cmulisp
+    bar		cmulisp<2>
+    *cmulisp*   cmulisp<3>
+If you do a \\[lisp-eval-defun] command on some Lisp source code, 
+what process do you send it to?
+
+- If you're in a process buffer (foo, bar, or *cmulisp*), 
+  you send it to that process.
+- If you're in some other buffer (e.g., a source file), you
+  send it to the process attached to buffer cmulisp-buffer.
+This process selection is performed by function cmulisp-proc.
+
+Whenever \\[cmulisp] fires up a new process, it resets cmulisp-buffer
+to be the new process's buffer. If you only run one process, this will
+do the right thing. If you run multiple processes, you can change
+cmulisp-buffer to another process buffer with \\[set-variable].
+
+More sophisticated approaches are, of course, possible. If you find youself
+needing to switch back and forth between multiple processes frequently,
+you may wish to consider ilisp.el, a larger, more sophisticated package
+for running inferior Lisp processes. The approach taken here is for a
+minimal, simple implementation. Feel free to extend it.")
+
+(defun cmulisp-proc ()
+  "Returns the current cmulisp process. See variable cmulisp-buffer."
+  (let ((proc (get-buffer-process (if (eq major-mode 'inferior-lisp-mode)
+				      (current-buffer)
+				      cmulisp-buffer))))
+    (or proc
+	(error "No current process. See variable cmulisp-buffer"))))
+
+
+;;; Do the user's customisation...
+;;;===============================
+(defvar cmulisp-load-hook nil
+  "This hook is run when cmulisp is loaded in.
+This is a good place to put keybindings.")
+	
+(run-hooks 'cmulisp-load-hook)
+
+;;; CHANGE LOG
+;;; ===========================================================================
+;;; 5/24/90 Olin
+;;; - Split cmulisp and cmushell modes into separate files. 
+;;;   Not only is this a good idea, it's apparently the way it'll be rel 19.
+;;; - Upgraded process sends to use comint-send-string instead of
+;;;   process-send-string.
+;;; - Explicit references to process "cmulisp" have been replaced with
+;;;   (cmulisp-proc). This allows better handling of multiple process bufs.
+;;; - Added process query and var/function/symbol documentation
+;;;   commands. Based on code written by Douglas Roberts.
+;;; - Added lisp-eval-last-sexp, bound to C-x C-e.
+;;;
+;;; 9/20/90 Olin
+;;; Added a save-restriction to lisp-fn-called-at-pt. This bug and fix
+;;; reported by Lennart Staflin.
+;;;
+;;; 3/12/90 Olin
+;;; - lisp-load-file and lisp-compile-file no longer switch-to-lisp.
+;;;   Tale suggested this.
+;;; - Reversed this decision 7/15/91. You need the visual feedback.
+;;;
+;;; 7/25/91 Olin
+;;; Changed all keybindings of the form C-c <letter>. These are
+;;; supposed to be reserved for the user to bind. This affected
+;;; mainly the compile/eval-defun/region[-and-go] commands.
+;;; This was painful, but necessary to adhere to the gnumacs standard.
+;;; For some backwards compatibility, see the 
+;;;     cmulisp-install-letter-bindings
+;;; function.
+;;;
+;;; 8/2/91 Olin
+;;; - The lisp-compile/eval-defun/region commands now take a prefix arg,
+;;;   which means switch-to-lisp after sending the text to the Lisp process.
+;;;   This obsoletes all the -and-go commands. The -and-go commands are
+;;;   kept around for historical reasons, and because the user can bind
+;;;   them to key sequences shorter than C-u C-c C-<letter>.
+;;; - If M-x cmulisp is invoked with a prefix arg, it allows you to
+;;;   edit the command line.
+;;;
+;;; 11/91 Olin
+;;; Added a (kill-all-local-variables) to cmulisp-mode, because comint-mode
+;;; doesn't do it anymore.
+;;;
+;;; 12/91 Olin
+;;; Changed a bogus recursion in cmulisp-args-to-list from 
+;;; tea-args-to-list to cmulisp-args-to-lisp. The perils of cut-and-paste
+;;; programming. Bug reported by Miles Bader, who also suggested replacing
+;;; the whole bogus parser with /bin/sh -c.
+
+(provide 'cmulisp)
diff --git a/emacs/cmuscheme.el b/emacs/cmuscheme.el
new file mode 100644
index 0000000..bb05667
--- /dev/null
+++ b/emacs/cmuscheme.el
@@ -0,0 +1,433 @@
+;;; cmuscheme.el -- Scheme process in a buffer. Adapted from tea.el.
+;;; Copyright Olin Shivers (1988)
+;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright
+;;; notice appearing here to the effect that you may use this code any
+;;; way you like, as long as you don't charge money for it, remove this
+;;; notice, or hold me liable for its results.
+;;;
+;;;    This is a customisation of comint-mode (see comint.el)
+;;;
+;;; Written by Olin Shivers (olin.shivers@cs.cmu.edu). With bits and pieces
+;;; lifted from scheme.el, shell.el, clisp.el, newclisp.el, cobol.el, et al..
+;;; 8/88
+;;;
+;;; Please send me bug reports, bug fixes, and extensions, so that I can
+;;; merge them into the master source.
+;;;
+;;; The changelog is at the end of this file.
+;;;
+;;; NOTE: MIT Cscheme, when invoked with the -emacs flag, has a special user
+;;; interface that communicates process state back to the superior emacs by
+;;; outputting special control sequences. The gnumacs package, xscheme.el, has
+;;; lots and lots of special purpose code to read these control sequences, and
+;;; so is very tightly integrated with the cscheme process. The cscheme
+;;; interrupt handler and debugger read single character commands in cbreak
+;;; mode; when this happens, xscheme.el switches to special keymaps that bind
+;;; the single letter command keys to emacs functions that directly send the
+;;; character to the scheme process.  Cmuscheme mode does *not* provide this
+;;; functionality. If you are a cscheme user, you may prefer to use the
+;;; xscheme.el/cscheme -emacs interaction.
+;;; 
+;;; Here's a summary of the pros and cons, as I see them.
+;;; xscheme: Tightly integrated with inferior cscheme process!  A few commands
+;;;	     not in cmuscheme. But. Integration is a bit of a hack.  Input
+;;;	     history only keeps the immediately prior input. Bizarre
+;;;	     keybindings.
+;;; 
+;;; cmuscheme: Not tightly integrated with inferior cscheme process.  But.
+;;;            Carefully integrated functionality with the entire suite of
+;;;            comint-derived CMU process modes. Keybindings reminiscent of
+;;;            Zwei and Hemlock. Good input history. A few commands not in
+;;;            xscheme.
+;;;  
+;;; It's a tradeoff. Pay your money; take your choice. If you use a Scheme
+;;; that isn't Cscheme, of course, there isn't a choice. Xscheme.el is *very*
+;;; Cscheme-specific; you must use cmuscheme.el.  Interested parties are
+;;; invited to port xscheme functionality on top of comint mode...
+
+;; YOUR .EMACS FILE
+;;=============================================================================
+;; Some suggestions for your .emacs file.
+;;
+;; ; If cmuscheme lives in some non-standard directory, you must tell emacs
+;; ; where to get it. This may or may not be necessary.
+;; (setq load-path (cons (expand-file-name "~jones/lib/emacs") load-path))
+;;
+;; ; Autoload run-scheme from file cmuscheme.el
+;; (autoload 'run-scheme "cmuscheme"
+;;           "Run an inferior Scheme process."
+;;           t)
+;;
+;; ; Files ending in ".scm" are Scheme source, 
+;; ; so put their buffers in scheme-mode.
+;; (setq auto-mode-alist 
+;;       (cons '("\\.scm$" . scheme-mode)  
+;;             auto-mode-alist))
+;;
+;; ; Define C-c C-t to run my favorite command in inferior scheme mode:
+;; (setq cmuscheme-load-hook
+;;       '((lambda () (define-key inferior-scheme-mode-map "\C-c\C-t"
+;;                                'favorite-cmd))))
+;;;
+;;; Unfortunately, scheme.el defines run-scheme to autoload from xscheme.el.
+;;; This will womp your declaration to autoload run-scheme from cmuscheme.el
+;;; if you haven't loaded cmuscheme in before scheme. Three fixes:
+;;; - Put the autoload on your scheme mode hook and in your .emacs toplevel:
+;;;   (setq scheme-mode-hook
+;;;         '((lambda () (autoload 'run-scheme "cmuscheme"
+;;;                                "Run an inferior Scheme" t))))
+;;;   (autoload 'run-scheme "cmuscheme" "Run an inferior Scheme" t)
+;;;   Now when scheme.el autoloads, it will restore the run-scheme autoload.
+;;; - Load cmuscheme.el in your .emacs: (load-library 'cmuscheme)
+;;; - Change autoload declaration in scheme.el to point to cmuscheme.el:
+;;;   (autoload 'run-scheme "cmuscheme" "Run an inferior Scheme" t)
+;;;   *or* just delete the autoload declaration from scheme.el altogether,
+;;;   which will allow the autoload in your .emacs to have its say.
+
+(provide 'cmuscheme)
+(require 'scheme)
+(require 'comint)
+
+;;; INFERIOR SCHEME MODE STUFF
+;;;============================================================================
+
+(defvar inferior-scheme-mode-hook nil
+  "*Hook for customising inferior-scheme mode.")
+(defvar inferior-scheme-mode-map nil)
+
+(cond ((not inferior-scheme-mode-map)
+       (setq inferior-scheme-mode-map
+	     (copy-keymap comint-mode-map))
+       (define-key inferior-scheme-mode-map "\M-\C-x" ;gnu convention
+	           'scheme-send-definition)
+       (define-key inferior-scheme-mode-map "\C-x\C-e" 'scheme-send-last-sexp)
+       (define-key inferior-scheme-mode-map "\C-cl"    'scheme-load-file)
+       (define-key inferior-scheme-mode-map "\C-ck"    'scheme-compile-file)
+       (scheme-mode-commands inferior-scheme-mode-map))) 
+
+;; Install the process communication commands in the scheme-mode keymap.
+(define-key scheme-mode-map "\M-\C-x" 'scheme-send-definition);gnu convention
+(define-key scheme-mode-map "\C-x\C-e" 'scheme-send-last-sexp);gnu convention
+(define-key scheme-mode-map "\C-ce"    'scheme-send-definition)
+(define-key scheme-mode-map "\C-c\C-e" 'scheme-send-definition-and-go)
+(define-key scheme-mode-map "\C-cr"    'scheme-send-region)
+(define-key scheme-mode-map "\C-c\C-r" 'scheme-send-region-and-go)
+(define-key scheme-mode-map "\C-cc"    'scheme-compile-definition)
+(define-key scheme-mode-map "\C-c\C-c" 'scheme-compile-definition-and-go)
+(define-key scheme-mode-map "\C-cz"    'switch-to-scheme)
+(define-key scheme-mode-map "\C-cl"    'scheme-load-file)
+(define-key scheme-mode-map "\C-ck"    'scheme-compile-file) ;k for "kompile"
+
+(defun inferior-scheme-mode ()
+  "Major mode for interacting with an inferior Scheme process.
+
+The following commands are available:
+\\{inferior-scheme-mode-map}
+
+A Scheme process can be fired up with M-x run-scheme.
+
+Customisation: Entry to this mode runs the hooks on comint-mode-hook and
+inferior-scheme-mode-hook (in that order).
+
+You can send text to the inferior Scheme process from other buffers containing
+Scheme source.  
+    switch-to-scheme switches the current buffer to the Scheme process buffer.
+    scheme-send-definition sends the current definition to the Scheme process.
+    scheme-compile-definition compiles the current definition.
+    scheme-send-region sends the current region to the Scheme process.
+    scheme-compile-region compiles the current region.
+
+    scheme-send-definition-and-go, scheme-compile-definition-and-go,
+        scheme-send-region-and-go, and scheme-compile-region-and-go
+        switch to the Scheme process buffer after sending their text.
+For information on running multiple processes in multiple buffers, see
+documentation for variable scheme-buffer.
+
+Commands:
+Return after the end of the process' output sends the text from the 
+    end of process to point.
+Return before the end of the process' output copies the sexp ending at point
+    to the end of the process' output, and sends it.
+Delete converts tabs to spaces as it moves back.
+Tab indents for Scheme; with argument, shifts rest
+    of expression rigidly with the current line.
+C-M-q does Tab on each line starting within following expression.
+Paragraphs are separated only by blank lines.  Semicolons start comments.
+If you accidentally suspend your process, use \\[comint-continue-subjob]
+to continue it."
+  (interactive)
+  (comint-mode)
+  ;; Customise in inferior-scheme-mode-hook
+  (setq comint-prompt-regexp "^[^>]*>+ *") ; OK for cscheme, oaklisp, T,...
+  (scheme-mode-variables)
+  (setq major-mode 'inferior-scheme-mode)
+  (setq mode-name "Inferior Scheme")
+  (setq mode-line-process '(": %s"))
+  (use-local-map inferior-scheme-mode-map)
+  (setq comint-input-filter (function scheme-input-filter))
+  (setq comint-input-sentinel (function ignore))
+  (setq comint-get-old-input (function scheme-get-old-input))
+  (run-hooks 'inferior-scheme-mode-hook))
+
+(defun scheme-input-filter (str)
+  "Don't save anything matching inferior-scheme-filter-regexp"
+  (not (string-match inferior-scheme-filter-regexp str)))
+
+(defvar inferior-scheme-filter-regexp "\\`\\s *\\S ?\\S ?\\s *\\'"
+  "*Input matching this regexp are not saved on the history list.
+Defaults to a regexp ignoring all inputs of 0, 1, or 2 letters.")
+
+(defun scheme-get-old-input ()
+  "Snarf the sexp ending at point"
+  (save-excursion
+    (let ((end (point)))
+      (backward-sexp)
+      (buffer-substring (point) end))))
+
+(defun scheme-args-to-list (string)
+  (let ((where (string-match "[ \t]" string)))
+    (cond ((null where) (list string))
+	  ((not (= where 0))
+	   (cons (substring string 0 where)
+		 (scheme-args-to-list (substring string (+ 1 where)
+						 (length string)))))
+	  (t (let ((pos (string-match "[^ \t]" string)))
+	       (if (null pos)
+		   nil
+		 (scheme-args-to-list (substring string pos
+						 (length string)))))))))
+
+(defvar scheme-program-name "scheme"
+  "*Program invoked by the run-scheme command")
+
+;;; Obsolete
+(defun scheme (&rest foo)
+  "Use run-scheme"
+  (interactive)
+  (message "Use run-scheme")
+  (ding))
+
+(defun run-scheme (cmd)
+  "Run an inferior Scheme process, input and output via buffer *scheme*.
+If there is a process already running in *scheme*, just switch to that buffer.
+With argument, allows you to edit the command line (default is value
+of scheme-program-name).  Runs the hooks from inferior-scheme-mode-hook
+\(after the comint-mode-hook is run).
+\(Type \\[describe-mode] in the process buffer for a list of commands.)"
+
+  (interactive (list (if current-prefix-arg
+			 (read-string "Run Scheme: " scheme-program-name)
+			 scheme-program-name)))
+  (if (not (comint-check-proc "*scheme*"))
+      (let ((cmdlist (scheme-args-to-list cmd)))
+	(set-buffer (apply 'make-comint "scheme" (car cmdlist)
+			   nil (cdr cmdlist)))
+	(inferior-scheme-mode)))
+  (setq scheme-buffer "*scheme*")
+  (switch-to-buffer "*scheme*"))
+
+
+(defun scheme-send-region (start end)
+  "Send the current region to the inferior Scheme process."
+  (interactive "r")
+  (comint-send-region (scheme-proc) start end)
+  (comint-send-string (scheme-proc) "\n"))
+
+(defun scheme-send-definition ()
+  "Send the current definition to the inferior Scheme process."
+  (interactive)
+  (save-excursion
+   (end-of-defun)
+   (let ((end (point)))
+     (beginning-of-defun)
+     (scheme-send-region (point) end))))
+
+(defun scheme-send-last-sexp ()
+  "Send the previous sexp to the inferior Scheme process."
+  (interactive)
+  (scheme-send-region (save-excursion (backward-sexp) (point)) (point)))
+
+(defvar scheme-compile-exp-command "(compile '%s)"
+  "*Template for issuing commands to compile arbitrary Scheme expressions.")
+
+(defun scheme-compile-region (start end)
+  "Compile the current region in the inferior Scheme process
+\(A BEGIN is wrapped around the region: (BEGIN <region>))"
+  (interactive "r")
+  (comint-send-string (scheme-proc) (format scheme-compile-exp-command
+					    (format "(begin %s)"
+						    (buffer-substring start end))))
+  (comint-send-string (scheme-proc) "\n"))
+
+(defun scheme-compile-definition ()
+  "Compile the current definition in the inferior Scheme process."
+  (interactive)
+  (save-excursion
+   (end-of-defun)
+   (let ((end (point)))
+     (beginning-of-defun)
+     (scheme-compile-region (point) end))))
+
+(defun switch-to-scheme (eob-p)
+  "Switch to the scheme process buffer.
+With argument, positions cursor at end of buffer."
+  (interactive "P")
+  (if (get-buffer scheme-buffer)
+      (pop-to-buffer scheme-buffer)
+      (error "No current process buffer. See variable scheme-buffer."))
+  (cond (eob-p
+	 (push-mark)
+	 (goto-char (point-max)))))
+
+(defun scheme-send-region-and-go (start end)
+  "Send the current region to the inferior Scheme process,
+and switch to the process buffer."
+  (interactive "r")
+  (scheme-send-region start end)
+  (switch-to-scheme t))
+
+(defun scheme-send-definition-and-go ()
+  "Send the current definition to the inferior Scheme, 
+and switch to the process buffer."
+  (interactive)
+  (scheme-send-definition)
+  (switch-to-scheme t))
+
+(defun scheme-compile-definition-and-go ()
+  "Compile the current definition in the inferior Scheme, 
+and switch to the process buffer."
+  (interactive)
+  (scheme-compile-definition)
+  (switch-to-scheme t))
+
+(defun scheme-compile-region-and-go (start end)
+  "Compile the current region in the inferior Scheme, 
+and switch to the process buffer."
+  (interactive "r")
+  (scheme-compile-region start end)
+  (switch-to-scheme t))
+
+(defvar scheme-source-modes '(scheme-mode)
+  "*Used to determine if a buffer contains Scheme source code.
+If it's loaded into a buffer that is in one of these major modes, it's
+considered a scheme source file by scheme-load-file and scheme-compile-file.
+Used by these commands to determine defaults.")
+
+(defvar scheme-prev-l/c-dir/file nil
+  "Caches the (directory . file) pair used in the last scheme-load-file or
+scheme-compile-file command. Used for determining the default in the 
+next one.")
+
+(defun scheme-load-file (file-name)
+  "Load a Scheme file into the inferior Scheme process."
+  (interactive (comint-get-source "Load Scheme file: " scheme-prev-l/c-dir/file
+				  scheme-source-modes t)) ; T because LOAD 
+                                                          ; needs an exact name
+  (comint-check-source file-name) ; Check to see if buffer needs saved.
+  (setq scheme-prev-l/c-dir/file (cons (file-name-directory    file-name)
+				       (file-name-nondirectory file-name)))
+  (comint-send-string (scheme-proc) (concat "(load \""
+					    file-name
+					    "\"\)\n")))
+
+(defun scheme-compile-file (file-name)
+  "Compile a Scheme file in the inferior Scheme process."
+  (interactive (comint-get-source "Compile Scheme file: "
+				  scheme-prev-l/c-dir/file
+				  scheme-source-modes
+				  nil)) ; NIL because COMPILE doesn't
+                                        ; need an exact name.
+  (comint-check-source file-name) ; Check to see if buffer needs saved.
+  (setq scheme-prev-l/c-dir/file (cons (file-name-directory    file-name)
+				       (file-name-nondirectory file-name)))
+  (comint-send-string (scheme-proc) (concat "(compile-file \""
+					    file-name
+					    "\"\)\n")))
+
+
+(defvar scheme-buffer nil "*The current scheme process buffer.
+
+MULTIPLE PROCESS SUPPORT
+===========================================================================
+Cmuscheme.el supports, in a fairly simple fashion, running multiple Scheme
+processes. To run multiple Scheme processes, you start the first up with
+\\[run-scheme]. It will be in a buffer named *scheme*. Rename this buffer
+with \\[rename-buffer]. You may now start up a new process with another
+\\[run-scheme]. It will be in a new buffer, named *scheme*. You can
+switch between the different process buffers with \\[switch-to-buffer].
+
+Commands that send text from source buffers to Scheme processes --
+like scheme-send-definition or scheme-compile-region -- have to choose a
+process to send to, when you have more than one Scheme process around. This
+is determined by the global variable scheme-buffer. Suppose you
+have three inferior Schemes running:
+    Buffer	Process
+    foo		scheme
+    bar		scheme<2>
+    *scheme*    scheme<3>
+If you do a \\[scheme-send-definition-and-go] command on some Scheme source
+code, what process do you send it to?
+
+- If you're in a process buffer (foo, bar, or *scheme*), 
+  you send it to that process.
+- If you're in some other buffer (e.g., a source file), you
+  send it to the process attached to buffer scheme-buffer.
+This process selection is performed by function scheme-proc.
+
+Whenever \\[run-scheme] fires up a new process, it resets scheme-buffer
+to be the new process's buffer. If you only run one process, this will
+do the right thing. If you run multiple processes, you can change
+scheme-buffer to another process buffer with \\[set-variable].
+
+More sophisticated approaches are, of course, possible. If you find youself
+needing to switch back and forth between multiple processes frequently,
+you may wish to consider ilisp.el, a larger, more sophisticated package
+for running inferior Lisp and Scheme processes. The approach taken here is
+for a minimal, simple implementation. Feel free to extend it.")
+
+(defun scheme-proc ()
+  "Returns the current scheme process. See variable scheme-buffer."
+  (let ((proc (get-buffer-process (if (eq major-mode 'inferior-scheme-mode)
+				      (current-buffer)
+				      scheme-buffer))))
+    (or proc
+	(error "No current process. See variable scheme-buffer"))))
+
+
+;;; Do the user's customisation...
+
+(defvar cmuscheme-load-hook nil
+  "This hook is run when cmuscheme is loaded in.
+This is a good place to put keybindings.")
+	
+(run-hooks 'cmuscheme-load-hook)
+
+
+;;; CHANGE LOG
+;;; ===========================================================================
+;;; 8/88 Olin
+;;; Created. 
+;;;
+;;; 2/15/89 Olin
+;;; Removed -emacs flag from process invocation. It's only useful for
+;;; cscheme, and makes cscheme assume it's running under xscheme.el,
+;;; which messes things up royally. A bug.
+;;;
+;;; 5/22/90 Olin
+;;; - Upgraded to use comint-send-string and comint-send-region.
+;;; - run-scheme now offers to let you edit the command line if
+;;;   you invoke it with a prefix-arg. M-x scheme is redundant, and
+;;;   has been removed.
+;;; - Explicit references to process "scheme" have been replaced with
+;;;   (scheme-proc). This allows better handling of multiple process bufs.
+;;; - Added scheme-send-last-sexp, bound to C-x C-e. A gnu convention.
+;;; - Have not added process query facility a la cmulisp.el's lisp-show-arglist
+;;;   and friends, but interested hackers might find a useful application
+;;;   of this facility.
+;;;
+;;; 3/12/90 Olin
+;;; - scheme-load-file and scheme-compile-file no longer switch-to-scheme.
+;;;   Tale suggested this.
+;;;
+;;; 2/21/94 JAR
+;;; - full-copy-sparse-keymap -> copy-keymap (thanks to Michael Sperber)
diff --git a/emacs/cmuscheme48.el b/emacs/cmuscheme48.el
new file mode 100644
index 0000000..b7b8888
--- /dev/null
+++ b/emacs/cmuscheme48.el
@@ -0,0 +1,99 @@
+;;; cmuscheme48.el -- Scheme process in a buffer.  Adapted from cmuscheme.el.
+
+(provide 'cmuscheme48)
+(require 'cmuscheme)
+
+(define-key scheme-mode-map "\M-\C-x" 'scheme48-send-definition);gnu convention
+(define-key scheme-mode-map "\C-x\C-e" 'scheme48-send-last-sexp);gnu convention
+(define-key scheme-mode-map "\C-ce"    'scheme48-send-definition)
+(define-key scheme-mode-map "\C-c\C-e" 'scheme48-send-definition-and-go)
+(define-key scheme-mode-map "\C-cr"    'scheme48-send-region)
+(define-key scheme-mode-map "\C-c\C-r" 'scheme48-send-region-and-go)
+(define-key scheme-mode-map "\C-cl"    'scheme48-load-file)
+
+(defun scheme48-send-region (start end)
+  "Send the current region to the inferior Scheme process."
+  (interactive "r")
+  (comint-send-string (scheme-proc)
+		      (concat ",from-file "
+			      (enough-scheme-file-name
+			       (buffer-file-name (current-buffer)))
+			      "\n"))
+  (comint-send-region (scheme-proc) start end)
+  (comint-send-string (scheme-proc) " ,end\n"))
+
+; This assumes that when you load things into Scheme 48, you type
+; names of files in your home directory using the syntax "~/".
+; Similarly for current directory.  Maybe we ought to send multiple
+; file names to Scheme and let it look at all of them.
+
+(defun enough-scheme-file-name (file)
+  (let* ((scheme-dir
+	  (save-excursion
+	    (set-buffer scheme-buffer)
+	    (expand-file-name default-directory)))
+	 (len (length scheme-dir)))
+    (if (and (> (length file) len)
+	     (string-equal scheme-dir (substring file 0 len)))
+	(substring file len)
+	(if *scheme48-home-directory-kludge*
+	    (let* ((home-dir (expand-file-name "~/"))
+		   (len (length home-dir)))
+	      (if (and (> (length file) len)
+		       (string-equal home-dir (substring file 0 len)))
+		  (concat "~/" (substring file len))
+		  file))
+	    file))))
+
+(defvar *scheme48-home-directory-kludge* t)
+
+(defun scheme48-send-definition (losep)
+  "Send the current definition to the inferior Scheme48 process."
+  (interactive "P")
+  (save-excursion
+   (end-of-defun)
+   (let ((end (point)))
+     (beginning-of-defun)
+     (if losep
+	 (let ((loser "/tmp/s48lose.tmp"))
+	   (write-region (point) end loser)
+	   (scheme48-load-file loser))
+	 (scheme48-send-region (point) end)))))
+
+(defun scheme48-send-last-sexp ()
+  "Send the previous sexp to the inferior Scheme process."
+  (interactive)
+  (scheme48-send-region (save-excursion (backward-sexp) (point)) (point)))
+
+(defun scheme48-send-region-and-go (start end)
+  "Send the current region to the inferior Scheme48 process,
+and switch to the process buffer."
+  (interactive "r")
+  (scheme48-send-region start end)
+  (switch-to-scheme t))
+
+(defun scheme48-send-definition-and-go (losep)
+  "Send the current definition to the inferior Scheme48,
+and switch to the process buffer."
+  (interactive "P")
+  (scheme48-send-definition losep)
+  (switch-to-scheme t))
+
+(defun scheme48-load-file (file-name)
+  "Load a Scheme file into the inferior Scheme48 process."
+  (interactive (comint-get-source "Load Scheme48 file: "
+				  scheme-prev-l/c-dir/file
+				  scheme-source-modes t)) ; T because LOAD 
+                                                          ; needs an exact name
+  (comint-check-source file-name) ; Check to see if buffer needs saved.
+  (setq scheme-prev-l/c-dir/file (cons (file-name-directory    file-name)
+				       (file-name-nondirectory file-name)))
+  (comint-send-string (scheme-proc)
+		      (concat ",load "
+			      (enough-scheme-file-name file-name)
+			      "\n")))
+
+
+; For Pertti Kellom\"aki's debugger.
+; Cf. misc/psd-s48.scm.
+(defvar psd-using-slib nil "Scheme 48, not SLIB.")
diff --git a/emacs/cmushell.el b/emacs/cmushell.el
new file mode 100644
index 0000000..bc20f17
--- /dev/null
+++ b/emacs/cmushell.el
@@ -0,0 +1,594 @@
+;;; -*-Emacs-Lisp-*- General command interpreter in a window stuff
+;;; Copyright Olin Shivers (1988).
+;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright
+;;; notice appearing here to the effect that you may use this code any
+;;; way you like, as long as you don't charge money for it, remove this
+;;; notice, or hold me liable for its results.
+
+;;; The changelog is at the end of file.
+
+;;; Please send me bug reports, bug fixes, and extensions, so that I can
+;;; merge them into the master source.
+;;;     - Olin Shivers (shivers@cs.cmu.edu)
+
+;;; This file defines a a shell-in-a-buffer package (cmushell mode) built on
+;;; top of comint mode.  Cmushell mode is similar to, and intended to replace,
+;;; its counterpart in the standard gnu emacs release. This replacement is
+;;; more featureful, robust, and uniform than the released version.
+
+;;; Since this mode is built on top of the general command-interpreter-in-
+;;; a-buffer mode (comint mode), it shares a common base functionality, 
+;;; and a common set of bindings, with all modes derived from comint mode.
+;;; This makes these modes easier to use.
+
+;;; For documentation on the functionality provided by comint mode, and
+;;; the hooks available for customising it, see the file comint.el.
+;;; For further information on cmushell mode, see the comments below.
+
+;;; Needs fixin:
+;;; When sending text from a source file to a subprocess, the process-mark can 
+;;; move off the window, so you can lose sight of the process interactions.
+;;; Maybe I should ensure the process mark is in the window when I send
+;;; text to the process? Switch selectable?
+
+(require 'comint)
+(provide 'cmushell)
+
+;; YOUR .EMACS FILE
+;;=============================================================================
+;; Some suggestions for your .emacs file.
+;;
+;; ; If cmushell lives in some non-standard directory, you must tell emacs
+;; ; where to get it. This may or may not be necessary.
+;; (setq load-path (cons (expand-file-name "~jones/lib/emacs") load-path))
+;;
+;; ; Autoload cmushell from file cmushell.el
+;; (autoload 'cmushell "cmushell"
+;;           "Run an inferior shell process."
+;;           t)
+;;
+;; ; Define C-c C-t to run my favorite command in cmushell mode:
+;; (setq cmushell-load-hook
+;;       '((lambda () 
+;;           (define-key cmushell-mode-map "\C-c\C-t" 'favorite-cmd))))
+
+
+;;; Brief Command Documentation:
+;;;============================================================================
+;;; Comint Mode Commands: (common to cmushell and all comint-derived modes)
+;;;
+;;; m-p	    comint-previous-input    	    Cycle backwards in input history
+;;; m-n	    comint-next-input  	    	    Cycle forwards
+;;; c-c r   comint-previous-input-matching  Search backwards in input history
+;;; return  comint-send-input
+;;; c-a     comint-bol                      Beginning of line; skip prompt.
+;;; c-d	    comint-delchar-or-maybe-eof	    Delete char unless at end of buff.
+;;; c-c c-u comint-kill-input	    	    ^u
+;;; c-c c-w backward-kill-word    	    ^w
+;;; c-c c-c comint-interrupt-subjob 	    ^c
+;;; c-c c-z comint-stop-subjob	    	    ^z
+;;; c-c c-\ comint-quit-subjob	    	    ^\
+;;; c-c c-o comint-kill-output		    Delete last batch of process output
+;;; c-c c-r comint-show-output		    Show last batch of process output
+;;;         send-invisible                  Read line w/o echo & send to proc
+;;;         comint-continue-subjob	    Useful if you accidentally suspend
+;;;					        top-level job.
+;;; comint-mode-hook is the comint mode hook.
+
+;;; Shell Mode Commands:
+;;;         cmushell			    Fires up the shell process.
+;;; tab     comint-dynamic-complete	    Complete a partial file name
+;;; m-?     comint-dynamic-list-completions List completions in help buffer
+;;; 	    dirs    			    Resync the buffer's dir stack.
+;;; 	    dirtrack-toggle                 Turn dir tracking on/off.
+;;;
+;;; The cmushell mode hook is cmushell-mode-hook
+;;; The cmushell-load-hook is run after this file is loaded.
+;;; comint-prompt-regexp is initialised to shell-prompt-pattern, for backwards
+;;; compatibility.
+
+;;; Read the rest of this file for more information.
+
+;;; SHELL.EL COMPATIBILITY
+;;;============================================================================
+;;; In brief: this package should have no trouble coexisting with shell.el.
+;;; 
+;;; Most customising variables -- e.g., explicit-shell-file-name -- are the
+;;; same, so the users shouldn't have much trouble. Hooks have different
+;;; names, however, so you can customise shell mode differently from cmushell
+;;; mode. You basically just have to remember to type M-x cmushell instead of
+;;; M-x shell.
+;;; 
+;;; It would be nice if this file was completely plug-compatible with the old
+;;; shell package -- if you could just name this file shell.el, and have it
+;;; transparently replace the old one. But you can't.  Several other packages
+;;; (tex-mode, background, dbx, gdb, kermit, monkey, prolog, telnet) are also
+;;; clients of shell mode. These packages assume detailed knowledge of shell
+;;; mode internals in ways that are incompatible with cmushell mode (mostly
+;;; because of cmushell mode's greater functionality).  So, unless we are
+;;; willing to port all of these packages, we can't have this file be a
+;;; complete replacement for shell.el -- that is, we can't name this file
+;;; shell.el, and its main entry point (shell), because dbx.el will break
+;;; when it loads it in and tries to use it.
+;;; 
+;;; There are two ways to fix this. One: rewrite these other modes to use the
+;;; new package. This is a win, but can't be assumed. The other, backwards
+;;; compatible route, is to make this package non-conflict with shell.el, so
+;;; both files can be loaded in at the same time. And *that* is why some
+;;; functions and variables have different names: (cmushell),
+;;; cmushell-mode-map, that sort of thing. All the names have been carefully
+;;; chosen so that shell.el and cmushell.el won't tromp on each other.
+
+;;; Customisation and Buffer Variables
+;;; ===========================================================================
+;;; 
+
+;In loaddefs.el now.
+;(defconst shell-prompt-pattern
+;  "^[^#$%>]*[#$%>] *"
+;  "*Regexp used by Newline command to match subshell prompts.
+;;; Change the doc string for shell-prompt-pattern:
+(put 'shell-prompt-pattern 'variable-documentation
+  "Regexp to match prompts in the inferior shell.
+Defaults to \"^[^#$%>]*[#$%>] *\", which works pretty well.
+This variable is used to initialise comint-prompt-regexp in the 
+shell buffer.
+
+This is a fine thing to set in your .emacs file.")
+
+(defvar shell-popd-regexp "popd"
+  "*Regexp to match subshell commands equivalent to popd.")
+
+(defvar shell-pushd-regexp "pushd"
+  "*Regexp to match subshell commands equivalent to pushd.")
+
+(defvar shell-cd-regexp "cd"
+  "*Regexp to match subshell commands equivalent to cd.")
+
+(defvar explicit-shell-file-name nil
+  "*If non-nil, is file name to use for explicitly requested inferior shell.")
+
+(defvar explicit-csh-args
+  (if (eq system-type 'hpux)
+      ;; -T persuades HP's csh not to think it is smarter
+      ;; than us about what terminal modes to use.
+      '("-i" "-T")
+    '("-i"))
+  "*Args passed to inferior shell by M-x cmushell, if the shell is csh.
+Value is a list of strings, which may be nil.")
+
+;;; All the above vars aren't prefixed "cmushell-" to make them
+;;; backwards compatible w/shell.el and old .emacs files.
+
+(defvar cmushell-dirstack nil
+  "List of directories saved by pushd in this buffer's shell.")
+
+(defvar cmushell-dirstack-query "dirs"
+  "Command used by shell-resync-dirlist to query shell.")
+
+(defvar cmushell-mode-map '())
+(cond ((not cmushell-mode-map)
+       (setq cmushell-mode-map (full-copy-sparse-keymap comint-mode-map))
+       (define-key cmushell-mode-map "\t" 'comint-dynamic-complete)
+       (define-key cmushell-mode-map "\M-?"  'comint-dynamic-list-completions)))
+
+(defvar cmushell-mode-hook '()
+  "*Hook for customising cmushell mode")
+
+
+;;; Basic Procedures
+;;; ===========================================================================
+;;;
+
+(defun cmushell-mode ()
+  "Major mode for interacting with an inferior shell.
+Return after the end of the process' output sends the text from the 
+    end of process to the end of the current line.
+Return before end of process output copies rest of line to end (skipping
+    the prompt) and sends it.
+M-x send-invisible reads a line of text without echoing it, and sends it to
+    the shell.
+
+If you accidentally suspend your process, use \\[comint-continue-subjob]
+to continue it.
+
+cd, pushd and popd commands given to the shell are watched by Emacs to keep
+this buffer's default directory the same as the shell's working directory.
+M-x dirs queries the shell and resyncs Emacs' idea of what the current 
+    directory stack is.
+M-x dirtrack-toggle turns directory tracking on and off.
+
+\\{cmushell-mode-map}
+Customisation: Entry to this mode runs the hooks on comint-mode-hook and
+cmushell-mode-hook (in that order).
+
+Variables shell-cd-regexp, shell-pushd-regexp and shell-popd-regexp are used
+to match their respective commands."
+  (interactive)
+  (comint-mode)
+  (setq comint-prompt-regexp shell-prompt-pattern)
+  (setq major-mode 'cmushell-mode)
+  (setq mode-name "CMU shell")
+  (use-local-map cmushell-mode-map)
+  (make-local-variable 'cmushell-dirstack)
+  (setq cmushell-dirstack nil)
+  (make-local-variable 'cmushell-dirtrackp)
+  (setq cmushell-dirtrackp t)
+  (setq comint-input-sentinel 'cmushell-directory-tracker)
+  (run-hooks 'cmushell-mode-hook))
+
+
+(defun cmushell ()
+  "Run an inferior shell, with I/O through buffer *cmushell*.
+If buffer exists but shell process is not running, make new shell.
+If buffer exists and shell process is running, 
+ just switch to buffer *cmushell*.
+Program used comes from variable explicit-shell-file-name,
+ or (if that is nil) from the ESHELL environment variable,
+ or else from SHELL if there is no ESHELL.
+If a file ~/.emacs_SHELLNAME exists, it is given as initial input
+ (Note that this may lose due to a timing error if the shell
+  discards input when it starts up.)
+The buffer is put in cmushell-mode, giving commands for sending input
+and controlling the subjobs of the shell.  See cmushell-mode.
+See also variable shell-prompt-pattern.
+
+The shell file name (sans directories) is used to make a symbol name
+such as `explicit-csh-arguments'.  If that symbol is a variable,
+its value is used as a list of arguments when invoking the shell.
+Otherwise, one argument `-i' is passed to the shell.
+
+\(Type \\[describe-mode] in the shell buffer for a list of commands.)"
+  (interactive)
+  (let ((buffer-name (concat "*" cmushell-buffer-base-name "*")))
+    (cond ((not (comint-check-proc buffer-name))
+	   (let* ((prog (or explicit-shell-file-name
+			    (getenv "ESHELL")
+			    (getenv "SHELL")
+			    "/bin/sh"))		     
+		  (name (file-name-nondirectory prog))
+		  (startfile (concat "~/.emacs_" name))
+		  (xargs-name (intern-soft (concat "explicit-" name "-args"))))
+	     (set-buffer (apply 'make-comint cmushell-buffer-base-name prog
+				(if (file-exists-p startfile) startfile)
+				(if (and xargs-name (boundp xargs-name))
+				    (symbol-value xargs-name)
+				    '("-i"))))
+	     (cmushell-mode))))
+    (switch-to-buffer buffer-name)))
+
+(defvar cmushell-buffer-base-name "cmushell"
+  "Name of buffer in which CMU shell is to run.")
+
+
+;;; Directory tracking
+;;; ===========================================================================
+;;; This code provides the cmushell mode input sentinel
+;;;     CMUSHELL-DIRECTORY-TRACKER
+;;; that tracks cd, pushd, and popd commands issued to the shell, and
+;;; changes the current directory of the shell buffer accordingly.
+;;;
+;;; This is basically a fragile hack, although it's more accurate than
+;;; the released version in shell.el. It has the following failings:
+;;; 1. It doesn't know about the cdpath shell variable.
+;;; 2. It only spots the first command in a command sequence. E.g., it will
+;;;    miss the cd in "ls; cd foo"
+;;; 3. More generally, any complex command (like ";" sequencing) is going to
+;;;    throw it. Otherwise, you'd have to build an entire shell interpreter in
+;;;    emacs lisp.  Failing that, there's no way to catch shell commands where
+;;;    cd's are buried inside conditional expressions, aliases, and so forth.
+;;;
+;;; The whole approach is a crock. Shell aliases mess it up. File sourcing
+;;; messes it up. You run other processes under the shell; these each have
+;;; separate working directories, and some have commands for manipulating
+;;; their w.d.'s (e.g., the lcd command in ftp). Some of these programs have
+;;; commands that do *not* affect the current w.d. at all, but look like they
+;;; do (e.g., the cd command in ftp).  In shells that allow you job
+;;; control, you can switch between jobs, all having different w.d.'s. So
+;;; simply saying %3 can shift your w.d..
+;;;
+;;; The solution is to relax, not stress out about it, and settle for
+;;; a hack that works pretty well in typical circumstances. Remember
+;;; that a half-assed solution is more in keeping with the spirit of Unix, 
+;;; anyway. Blech.
+;;;
+;;; One good hack not implemented here for users of programmable shells
+;;; is to program up the shell w.d. manipulation commands to output
+;;; a coded command sequence to the tty. Something like
+;;;     ESC | <cwd> |
+;;; where <cwd> is the new current working directory. Then trash the
+;;; directory tracking machinery currently used in this package, and
+;;; replace it with a process filter that watches for and strips out
+;;; these messages.
+
+;;; REGEXP is a regular expression. STR is a string. START is a fixnum.
+;;; Returns T if REGEXP matches STR where the match is anchored to start
+;;; at position START in STR. Sort of like LOOKING-AT for strings.
+(defun cmushell-front-match (regexp str start)
+  (eq start (string-match regexp str start)))
+
+(defun cmushell-directory-tracker (str)
+  "Tracks cd, pushd and popd commands issued to the shell.
+This function is called on each input passed to the shell.
+It watches for cd, pushd and popd commands and sets the buffer's
+default directory to track these commands.
+
+You may toggle this tracking on and off with M-x dirtrack-toggle.
+If emacs gets confused, you can resync with the shell with M-x dirs.
+
+See variables shell-cd-regexp, shell-pushd-regexp, and shell-popd-regexp.
+Environment variables are expanded, see function substitute-in-file-name."
+  (condition-case err
+    (cond (cmushell-dirtrackp
+	   (string-match "^\\s *" str) ; skip whitespace
+	   (let ((bos (match-end 0))
+		 (x nil))
+	     (cond ((setq x (cmushell-match-cmd-w/optional-arg shell-popd-regexp
+							       str bos))
+		    (cmushell-process-popd (substitute-in-file-name x)))
+		   ((setq x (cmushell-match-cmd-w/optional-arg shell-pushd-regexp
+							       str bos))
+		    (cmushell-process-pushd (substitute-in-file-name x)))
+		   ((setq x (cmushell-match-cmd-w/optional-arg shell-cd-regexp
+							       str bos))
+		    (cmushell-process-cd (substitute-in-file-name x)))))))
+    (error (message (car (cdr err))))))
+
+
+;;; Try to match regexp CMD to string, anchored at position START.
+;;; CMD may be followed by a single argument. If a match, then return
+;;; the argument, if there is one, or the empty string if not. If
+;;; no match, return nil.
+
+(defun cmushell-match-cmd-w/optional-arg (cmd str start)
+  (and (cmushell-front-match cmd str start)
+       (let ((eoc (match-end 0))) ; end of command
+	 (cond ((cmushell-front-match "\\s *\\(\;\\|$\\)" str eoc)
+		"")			; no arg
+	       ((cmushell-front-match "\\s +\\([^ \t\;]+\\)\\s *\\(\;\\|$\\)"
+				      str eoc)
+		(substring str (match-beginning 1) (match-end 1))) ; arg
+	       (t nil))))) ; something else.
+;;; The first regexp is [optional whitespace, (";" or the end of string)].
+;;; The second regexp is [whitespace, (an arg), optional whitespace,
+;;;     (";" or end of string)].
+
+
+;;; popd [+n]
+(defun cmushell-process-popd (arg)
+  (let ((num (if (zerop (length arg)) 0 ; no arg means +0
+		 (cmushell-extract-num arg))))
+    (if (and num (< num (length cmushell-dirstack)))
+	(if (= num 0) ; condition-case because the CD could lose.
+	    (condition-case nil (progn (cd (car cmushell-dirstack))
+				       (setq cmushell-dirstack
+					     (cdr cmushell-dirstack))
+				       (cmushell-dirstack-message))
+	      (error (message "Couldn't cd.")))
+	    (let* ((ds (cons nil cmushell-dirstack))
+		   (cell (nthcdr (- num 1) ds)))
+	      (rplacd cell (cdr (cdr cell)))
+	      (setq cmushell-dirstack (cdr ds))
+	      (cmushell-dirstack-message)))
+	(message "Bad popd."))))
+
+
+;;; cd [dir]
+(defun cmushell-process-cd (arg)
+  (condition-case nil (progn (cd (if (zerop (length arg)) (getenv "HOME")
+				     arg))
+			     (cmushell-dirstack-message))
+	   (error (message "Couldn't cd."))))
+
+
+;;; pushd [+n | dir]
+(defun cmushell-process-pushd (arg)
+  (if (zerop (length arg))
+      ;; no arg -- swap pwd and car of shell stack
+      (condition-case nil (if cmushell-dirstack
+			      (let ((old default-directory))
+				(cd (car cmushell-dirstack))
+				(setq cmushell-dirstack
+				      (cons old (cdr cmushell-dirstack)))
+				(cmushell-dirstack-message))
+			      (message "Directory stack empty."))
+	(message "Couldn't cd."))
+
+      (let ((num (cmushell-extract-num arg)))
+	(if num				; pushd +n
+	    (if (> num (length cmushell-dirstack))
+		(message "Directory stack not that deep.")
+		(let* ((ds (cons default-directory cmushell-dirstack))
+		       (dslen (length ds))
+		       (front (nthcdr num ds))
+		       (back (reverse (nthcdr (- dslen num) (reverse ds))))
+		       (new-ds (append front back)))
+		  (condition-case nil
+		      (progn (cd (car new-ds))
+			     (setq cmushell-dirstack (cdr new-ds))
+			     (cmushell-dirstack-message))
+		    (error (message "Couldn't cd.")))))
+	       
+	    ;; pushd <dir>
+	    (let ((old-wd default-directory))
+	      (condition-case nil
+		  (progn (cd arg)
+			 (setq cmushell-dirstack
+			       (cons old-wd cmushell-dirstack))
+			 (cmushell-dirstack-message))
+		(error (message "Couldn't cd."))))))))
+
+;; If STR is of the form +n, for n>0, return n. Otherwise, nil.
+(defun cmushell-extract-num (str)
+  (and (string-match "^\\+[1-9][0-9]*$" str)
+       (string-to-int str)))
+
+
+(defun cmushell-dirtrack-toggle ()
+  "Turn directory tracking on and off in a cmushell buffer."
+  (interactive)
+  (setq cmushell-dirtrackp (not cmushell-dirtrackp))
+  (message "directory tracking %s."
+	   (if cmushell-dirtrackp "ON" "OFF")))
+
+;;; For your typing convenience:
+(fset 'dirtrack-toggle 'cmushell-dirtrack-toggle)
+
+
+(defun cmushell-resync-dirs ()
+  "Resync the buffer's idea of the current directory stack.
+This command queries the shell with the command bound to 
+cmushell-dirstack-query (default \"dirs\"), reads the next
+line output and parses it to form the new directory stack.
+DON'T issue this command unless the buffer is at a shell prompt.
+Also, note that if some other subprocess decides to do output
+immediately after the query, its output will be taken as the
+new directory stack -- you lose. If this happens, just do the
+command again."
+  (interactive)
+  (let* ((proc (get-buffer-process (current-buffer)))
+	 (pmark (process-mark proc)))
+    (goto-char pmark)
+    (insert cmushell-dirstack-query) (insert "\n")
+    (sit-for 0) ; force redisplay
+    (comint-send-string proc cmushell-dirstack-query) 
+    (comint-send-string proc "\n")
+    (set-marker pmark (point))
+    (let ((pt (point))) ; wait for 1 line
+      ;; This extra newline prevents the user's pending input from spoofing us.
+      (insert "\n") (backward-char 1)
+      (while (not (looking-at ".+\n"))
+	(accept-process-output proc)
+	(goto-char pt)))
+    (goto-char pmark) (delete-char 1) ; remove the extra newline
+    ;; That's the dirlist. grab it & parse it.
+    (let* ((dl (buffer-substring (match-beginning 0) (- (match-end 0) 1)))
+	   (dl-len (length dl))
+	   (ds '())			; new dir stack
+	   (i 0))
+      (while (< i dl-len)
+	;; regexp = optional whitespace, (non-whitespace), optional whitespace
+	(string-match "\\s *\\(\\S +\\)\\s *" dl i) ; pick off next dir
+	(setq ds (cons (substring dl (match-beginning 1) (match-end 1))
+		       ds))
+	(setq i (match-end 0)))
+      (let ((ds (reverse ds)))
+	(condition-case nil
+	    (progn (cd (car ds))
+		   (setq cmushell-dirstack (cdr ds))
+		   (cmushell-dirstack-message))
+	  (error (message "Couldn't cd.")))))))
+
+;;; For your typing convenience:
+(fset 'dirs 'cmushell-resync-dirs)
+
+
+;;; Show the current dirstack on the message line.
+;;; Pretty up dirs a bit by changing "/usr/jqr/foo" to "~/foo".
+;;; (This isn't necessary if the dirlisting is generated with a simple "dirs".)
+;;; All the commands that mung the buffer's dirstack finish by calling
+;;; this guy.
+(defun cmushell-dirstack-message ()
+  (let ((msg "")
+	(ds (cons default-directory cmushell-dirstack)))
+    (while ds
+      (let ((dir (car ds)))
+	(if (string-match (format "^%s\\(/\\|$\\)" (getenv "HOME")) dir)
+	    (setq dir (concat "~/" (substring dir (match-end 0)))))
+	(if (string-equal dir "~/") (setq dir "~"))
+	(setq msg (concat msg dir " "))
+	(setq ds (cdr ds))))
+    (message msg)))
+
+
+
+;;; Interfacing to client packages (and converting them)
+;;;============================================================================
+;;; Several gnu packages (tex-mode, background, dbx, gdb, kermit, prolog, 
+;;; telnet are some) use the shell package as clients. Most of them would
+;;; be better off using the comint package directly, but they predate it.
+;;; The catch is that most of these packages (dbx, gdb, prolog, telnet)
+;;; assume total knowledge of all the local variables that shell mode
+;;; functions depend on. So they (kill-all-local-variables), then create
+;;; the few local variables that shell.el functions depend on. Alas,
+;;; cmushell.el functions depend on a different set of vars (for example,
+;;; the input history ring is a local variable in cmushell.el's shell mode,
+;;; whereas there is no input history ring in shell.el's shell mode).
+;;; So we have a situation where the greater functionality of cmushell.el
+;;; is biting us -- you can't just replace shell will cmushell.
+;;;
+;;; Altering these packages to use comint mode directly should *greatly*
+;;; improve their functionality, and is actually pretty easy. It's
+;;; mostly a matter of renaming a few variable names. See comint.el for more.
+;;;     -Olin
+
+
+
+;;; Do the user's customisation...
+;;;===============================
+(defvar cmushell-load-hook nil
+  "This hook is run when cmushell is loaded in.
+This is a good place to put keybindings.")
+	
+(run-hooks 'cmushell-load-hook)
+
+;;; Change Log
+;;; ===========================================================================
+;;; Olin 8/88
+;;; Created.
+;;;
+;;; Olin 5/26/90
+;;; - Split cmulisp and cmushell modes into separate files. 
+;;;   Not only is this a good idea, it's apparently the way it'll be rel 19.
+;;; - Souped up the directory tracking; it now can handle pushd, pushd +n, 
+;;;   and popd +n.
+;;; - Added cmushell-dirtrack-toggle command to toggle the directory
+;;;   tracking that cmushell tries to do. This is useful, for example,
+;;;   when you are running ftp -- it prevents the ftp "cd" command from
+;;;   spoofing the tracking machinery. This command is also named 
+;;;   dirtrack-toggle, so you need only type M-x dirtrack to run it.
+;;; - Added cmushell-resync-dirs command. This queries the shell
+;;;   for the current directory stack, and resets the buffer's stack
+;;;   accordingly. This command is also named dirs, so you need only type
+;;;   M-x dirs to run it.
+;;; - Bits of the new directory tracking code were adapted from source
+;;;   contributed by Vince Broman, Jeff Peck, and Barry Warsaw.
+;;; - See also the improvements made to comint.el at the same time.
+;;; - Renamed several variables. Mostly this comprised changing "shell"
+;;;   to "cmushell" in the names. The only variables that are not prefixed
+;;;   with "cmushell-" are the ones that are common with shell.el:
+;;;       explicit-shell-file-name shell-prompt-pattern explicit-csh-args 
+;;;       and shell-cd/popd/pushd-regexp
+;;;   The variables and functions that were changed to have "cmushell-" 
+;;;   prefixes are:
+;;;       shell-directory-stack (v), shell-directory-tracker (f)
+;;;   This should not affect users, only elisp hackers. Hopefully
+;;;   one day shell.el will just go away, and we can drop all this
+;;;   "cmushell" bullshit.
+;;; - Upgraded process sends to use comint-send-string instead of
+;;;   process-send-string.
+;;;
+;;; Olin 6/14/90
+;;; - If your shell is named <shellname>, and a variable named
+;;;   explicit-<shellname>-args exists, cmushell is supposed
+;;;   to use its value as the arglist to the shell invocation.
+;;;   E.g., if you define explicit-csh-args to be 
+;;;   ("-ifx"), then when cmushell cranks up a csh, it execs it
+;;;   as "csh -ifx". This is what is documented. What has actually
+;;;   been the case is that the variable checked is
+;;;   explicit-<shellname>-arguments, not explicit-<shellname>-args.
+;;;   The documentation has been changed to conform to the code (for
+;;;   backwards compatibility with shell.el). This bug is inherited from
+;;;   the same bug in shell.el.
+;;;   This bug reported by Stephen Anderson.
+;;;
+;;; Olin 9/5/90
+;;; - Arguments to cd, popd, and pushd now have their env vars expanded
+;;;   out by the tracking machinery. So if you say "cd $SRCDIR/funs", the
+;;;   $SRCDIR var will be replaced by its value *in emacs' process
+;;;   environment*. If this is different from the shell's binding of the
+;;;   variable, you lose.  Several users needed this feature, fragile
+;;;   though it may be.  The fix was contributed by sk@thp.Uni-Koeln.DE.
+;;;
+;;; Olin 3/12/91
+;;; - Moved comint-dynamic-complete (filename completion) from M-tab to tab.
diff --git a/emacs/comint.el b/emacs/comint.el
new file mode 100644
index 0000000..85d4bf6
--- /dev/null
+++ b/emacs/comint.el
@@ -0,0 +1,1372 @@
+;;; -*-Emacs-Lisp-*- General command interpreter in a window stuff
+;;; Copyright Olin Shivers (1988).
+;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright
+;;; notice appearing here to the effect that you may use this code any
+;;; way you like, as long as you don't charge money for it, remove this
+;;; notice, or hold me liable for its results.
+
+;;; The changelog is at the end of this file.
+
+;;; Please send me bug reports, bug fixes, and extensions, so that I can
+;;; merge them into the master source.
+;;;     - Olin Shivers (shivers@cs.cmu.edu)
+
+;;; This hopefully generalises shell mode, lisp mode, tea mode, soar mode,...
+;;; This file defines a general command-interpreter-in-a-buffer package
+;;; (comint mode). The idea is that you can build specific process-in-a-buffer
+;;; modes on top of comint mode -- e.g., lisp, shell, scheme, T, soar, ....
+;;; This way, all these specific packages share a common base functionality, 
+;;; and a common set of bindings, which makes them easier to use (and
+;;; saves code, implementation time, etc., etc.).
+
+;;; Several packages are already defined using comint mode:
+;;; - cmushell.el defines a shell-in-a-buffer mode.
+;;; - cmulisp.el defines a simple lisp-in-a-buffer mode.
+;;; Cmushell and cmulisp mode are similar to, and intended to replace,
+;;; their counterparts in the standard gnu emacs release (in shell.el). 
+;;; These replacements are more featureful, robust, and uniform than the 
+;;; released versions. The key bindings in lisp mode are also more compatible
+;;; with the bindings of Hemlock and Zwei (the Lisp Machine emacs).
+;;;
+;;; - The file cmuscheme.el defines a scheme-in-a-buffer mode.
+;;; - The file tea.el tunes scheme and inferior-scheme modes for T.
+;;; - The file soar.el tunes lisp and inferior-lisp modes for Soar.
+;;; - cmutex.el defines tex and latex modes that invoke tex, latex, bibtex,
+;;;   previewers, and printers from within emacs.
+;;; - background.el allows csh-like job control inside emacs.
+;;; It is pretty easy to make new derived modes for other processes.
+
+;;; For documentation on the functionality provided by comint mode, and
+;;; the hooks available for customising it, see the comments below.
+;;; For further information on the standard derived modes (shell, 
+;;; inferior-lisp, inferior-scheme, ...), see the relevant source files.
+
+;;; For hints on converting existing process modes (e.g., tex-mode,
+;;; background, dbx, gdb, kermit, prolog, telnet) to use comint-mode
+;;; instead of shell-mode, see the notes at the end of this file.
+
+(provide 'comint)
+(defconst comint-version "2.02")
+
+
+;;; Brief Command Documentation:
+;;;============================================================================
+;;; Comint Mode Commands: (common to all derived modes, like cmushell & cmulisp
+;;; mode)
+;;;
+;;; m-p	    comint-previous-input    	    Cycle backwards in input history
+;;; m-n	    comint-next-input  	    	    Cycle forwards
+;;; m-s     comint-previous-similar-input   Previous similar input
+;;; c-c r   comint-previous-input-matching  Search backwards in input history
+;;; return  comint-send-input
+;;; c-a     comint-bol                      Beginning of line; skip prompt.
+;;; c-d	    comint-delchar-or-maybe-eof     Delete char unless at end of buff.
+;;; c-c c-u comint-kill-input	    	    ^u
+;;; c-c c-w backward-kill-word    	    ^w
+;;; c-c c-c comint-interrupt-subjob 	    ^c
+;;; c-c c-z comint-stop-subjob	    	    ^z
+;;; c-c c-\ comint-quit-subjob	    	    ^\
+;;; c-c c-o comint-kill-output		    Delete last batch of process output
+;;; c-c c-r comint-show-output		    Show last batch of process output
+;;;
+;;; Not bound by default in comint-mode
+;;; send-invisible			Read a line w/o echo, and send to proc
+;;; (These are bound in shell-mode)
+;;; comint-dynamic-complete		Complete filename at point.
+;;; comint-dynamic-list-completions	List completions in help buffer.
+;;; comint-replace-by-expanded-filename	Expand and complete filename at point;
+;;;					replace with expanded/completed name.
+;;; comint-kill-subjob			No mercy.
+;;; comint-continue-subjob		Send CONT signal to buffer's process
+;;;					group. Useful if you accidentally
+;;;					suspend your process (with C-c C-z).
+;;;
+;;; Bound for RMS -- I prefer the input history stuff, but you might like 'em.
+;;; m-P	   comint-msearch-input		Search backwards for prompt
+;;; m-N    comint-psearch-input		Search forwards for prompt
+;;; C-cR   comint-msearch-input-matching Search backwards for prompt & string
+
+;;; comint-mode-hook is the comint mode hook. Basically for your keybindings.
+;;; comint-load-hook is run after loading in this package.
+
+
+;;; Buffer Local Variables:
+;;;============================================================================
+;;; Comint mode buffer local variables:
+;;;     comint-prompt-regexp    - string       comint-bol uses to match prompt.
+;;;     comint-last-input-end   - marker       For comint-kill-output command
+;;;     input-ring-size         - integer      For the input history
+;;;     input-ring              - ring             mechanism
+;;;     input-ring-index        - marker           ...
+;;;     comint-last-input-match - string           ...
+;;;     comint-get-old-input    - function     Hooks for specific 
+;;;     comint-input-sentinel   - function         process-in-a-buffer
+;;;     comint-input-filter     - function         modes.
+;;;     comint-input-send	- function
+;;;     comint-eol-on-send	- boolean
+
+(defvar comint-prompt-regexp "^"
+  "Regexp to recognise prompts in the inferior process.
+Defaults to \"^\", the null string at BOL.
+
+Good choices:
+  Canonical Lisp: \"^[^> ]*>+:? *\" (Lucid, franz, kcl, T, cscheme, oaklisp)
+  Lucid Common Lisp: \"^\\(>\\|\\(->\\)+\\) *\"
+  franz: \"^\\(->\\|<[0-9]*>:\\) *\"
+  kcl: \"^>+ *\"
+  shell: \"^[^#$%>]*[#$%>] *\"
+  T: \"^>+ *\"
+
+This is a good thing to set in mode hooks.")
+
+(defvar input-ring-size 30
+  "Size of input history ring.")
+
+;;; Here are the per-interpreter hooks.
+(defvar comint-get-old-input (function comint-get-old-input-default)
+  "Function that submits old text in comint mode.
+This function is called when return is typed while the point is in old text.
+It returns the text to be submitted as process input.  The default is
+comint-get-old-input-default, which grabs the current line, and strips off
+leading text matching comint-prompt-regexp")
+
+(defvar comint-input-sentinel (function ignore)
+  "Called on each input submitted to comint mode process by comint-send-input.
+Thus it can, for instance, track cd/pushd/popd commands issued to the csh.")
+
+(defvar comint-input-filter
+  (function (lambda (str) (not (string-match "\\`\\s *\\'" str))))
+  "Predicate for filtering additions to input history.
+Only inputs answering true to this function are saved on the input
+history list. Default is to save anything that isn't all whitespace")
+
+(defvar comint-input-sender (function comint-simple-send)
+  "Function to actually send to PROCESS the STRING submitted by user.
+Usually this is just 'comint-simple-send, but if your mode needs to 
+massage the input string, this is your hook. This is called from
+the user command comint-send-input. comint-simple-send just sends
+the string plus a newline.")
+
+(defvar comint-eol-on-send 'T
+  "If non-nil, then jump to the end of the line before sending input to process.
+See COMINT-SEND-INPUT")
+
+(defvar comint-mode-hook '()
+  "Called upon entry into comint-mode
+This is run before the process is cranked up.")
+
+(defvar comint-exec-hook '()
+  "Called each time a process is exec'd by comint-exec.
+This is called after the process is cranked up.  It is useful for things that
+must be done each time a process is executed in a comint-mode buffer (e.g.,
+(process-kill-without-query)). In contrast, the comint-mode-hook is only
+executed once when the buffer is created.")
+
+(defvar comint-mode-map nil)
+
+(defun comint-mode ()
+  "Major mode for interacting with an inferior interpreter.
+Interpreter name is same as buffer name, sans the asterisks.
+Return at end of buffer sends line as input.
+Return not at end copies rest of line to end and sends it.
+Setting mode variable comint-eol-on-send means jump to the end of the line
+before submitting new input.
+
+This mode is typically customised to create inferior-lisp-mode,
+shell-mode, etc.. This can be done by setting the hooks
+comint-input-sentinel, comint-input-filter, comint-input-sender and
+comint-get-old-input to appropriate functions, and the variable
+comint-prompt-regexp to the appropriate regular expression.
+
+An input history is maintained of size input-ring-size, and
+can be accessed with the commands comint-next-input [\\[comint-next-input]] and 
+comint-previous-input [\\[comint-previous-input]]. Commands not keybound by
+default are send-invisible, comint-dynamic-complete, and 
+comint-list-dynamic-completions.
+
+If you accidentally suspend your process, use \\[comint-continue-subjob]
+to continue it.
+
+\\{comint-mode-map}
+
+Entry to this mode runs the hooks on comint-mode-hook"
+  (interactive)
+  (let ((old-ring (and (assq 'input-ring (buffer-local-variables))
+		       (boundp 'input-ring)
+		       input-ring))
+	(old-ptyp comint-ptyp)) ; preserve across local var kill. gross.
+;   (kill-all-local-variables) ; Removed 1/15/90 Olin
+    (setq major-mode 'comint-mode)
+    (setq mode-name "Comint")
+    (setq mode-line-process '(": %s"))
+    (use-local-map comint-mode-map)
+    (make-local-variable 'comint-last-input-end)
+    (setq comint-last-input-end (make-marker))
+    (make-local-variable 'comint-last-input-match)
+    (setq comint-last-input-match "")
+    (make-local-variable 'comint-prompt-regexp) ; Don't set; default
+    (make-local-variable 'input-ring-size)      ; ...to global val.
+    (make-local-variable 'input-ring)
+    (make-local-variable 'input-ring-index)
+    (setq input-ring-index 0)
+    (make-local-variable 'comint-get-old-input)
+    (make-local-variable 'comint-input-sentinel)
+    (make-local-variable 'comint-input-filter)  
+    (make-local-variable 'comint-input-sender)
+    (make-local-variable 'comint-eol-on-send)
+    (make-local-variable 'comint-ptyp)
+    (setq comint-ptyp old-ptyp)
+    (make-local-variable 'comint-exec-hook)
+    (run-hooks 'comint-mode-hook)
+    ;Do this after the hook so the user can mung INPUT-RING-SIZE w/his hook.
+    ;The test is so we don't lose history if we run comint-mode twice in
+    ;a buffer.
+    (setq input-ring (if (ring-p old-ring) old-ring
+			 (make-ring input-ring-size)))))
+
+;;; The old-ptyp stuff above is because we have to preserve the value of
+;;; comint-ptyp across calls to comint-mode, in spite of the
+;;; kill-all-local-variables that it does. Blech. Hopefully, this will all
+;;; go away when a later release fixes the signalling bug.
+;;; (Later: I removed the kill-all-local-variables, but have left this
+;;; other code in place just in case I reverse myself.)
+
+(if comint-mode-map
+    nil
+  (setq comint-mode-map (make-sparse-keymap))
+  (define-key comint-mode-map "\ep" 'comint-previous-input)
+  (define-key comint-mode-map "\en" 'comint-next-input)
+  (define-key comint-mode-map "\es" 'comint-previous-similar-input)
+  (define-key comint-mode-map "\C-m" 'comint-send-input)
+  (define-key comint-mode-map "\C-d" 'comint-delchar-or-maybe-eof)
+  (define-key comint-mode-map "\C-a" 'comint-bol)
+  (define-key comint-mode-map "\C-c\C-u" 'comint-kill-input)
+  (define-key comint-mode-map "\C-c\C-w" 'backward-kill-word)
+  (define-key comint-mode-map "\C-c\C-c" 'comint-interrupt-subjob)
+  (define-key comint-mode-map "\C-c\C-z" 'comint-stop-subjob)
+  (define-key comint-mode-map "\C-c\C-\\" 'comint-quit-subjob)
+  (define-key comint-mode-map "\C-c\C-o" 'comint-kill-output)
+  (define-key comint-mode-map "\C-cr"    'comint-previous-input-matching)
+  (define-key comint-mode-map "\C-c\C-r" 'comint-show-output)
+  ;;; prompt-search commands commented out 3/90 -Olin
+; (define-key comint-mode-map "\eP" 'comint-msearch-input)
+; (define-key comint-mode-map "\eN" 'comint-psearch-input)
+; (define-key comint-mode-map "\C-cR" 'comint-msearch-input-matching)
+  )
+
+
+;;; This function is used to make a full copy of the comint mode map,
+;;; so that client modes won't interfere with each other. This function
+;;; isn't necessary in emacs 18.5x, but we keep it around for 18.4x versions.
+(defun full-copy-sparse-keymap (km)
+  "Recursively copy the sparse keymap KM"
+  (cond ((consp km)
+	 (cons (full-copy-sparse-keymap (car km))
+	       (full-copy-sparse-keymap (cdr km))))
+	(t km)))
+
+(defun comint-check-proc (buffer)
+  "True if there is a process associated w/buffer BUFFER, and
+it is alive (status RUN or STOP). BUFFER can be either a buffer or the
+name of one"
+  (let ((proc (get-buffer-process buffer)))
+    (and proc (memq (process-status proc) '(run stop)))))
+
+;;; Note that this guy, unlike shell.el's make-shell, barfs if you pass it ()
+;;; for the second argument (program).
+(defun make-comint (name program &optional startfile &rest switches)
+  (let ((buffer (get-buffer-create (concat "*" name "*"))))
+    ;; If no process, or nuked process, crank up a new one and put buffer in
+    ;; comint mode. Otherwise, leave buffer and existing process alone.
+    (cond ((not (comint-check-proc buffer))
+	   (save-excursion
+	     (set-buffer buffer)
+	     (comint-mode)) ; Install local vars, mode, keymap, ...
+	   (comint-exec buffer name program startfile switches)))
+    buffer))
+
+(defvar comint-ptyp t
+  "True if communications via pty; false if by pipe. Buffer local.
+This is to work around a bug in emacs process signalling.")
+
+(defun comint-exec (buffer name command startfile switches)
+  "Fires up a process in buffer for comint modes.
+Blasts any old process running in the buffer. Doesn't set the buffer mode.
+You can use this to cheaply run a series of processes in the same comint
+buffer. The hook comint-exec-hook is run after each exec."
+  (save-excursion
+    (set-buffer buffer)
+    (let ((proc (get-buffer-process buffer)))	; Blast any old process.
+      (if proc (delete-process proc)))
+    ;; Crank up a new process
+    (let ((proc (comint-exec-1 name buffer command switches)))
+      (make-local-variable 'comint-ptyp)
+      (setq comint-ptyp process-connection-type) ; T if pty, NIL if pipe.
+      ;; Jump to the end, and set the process mark.
+      (goto-char (point-max))
+      (set-marker (process-mark proc) (point))
+      ;; Feed it the startfile.
+      (cond (startfile
+	     ;;This is guaranteed to wait long enough
+	     ;;but has bad results if the comint does not prompt at all
+	     ;;	     (while (= size (buffer-size))
+	     ;;	       (sleep-for 1))
+	     ;;I hope 1 second is enough!
+	     (sleep-for 1)
+	     (goto-char (point-max))
+	     (insert-file-contents startfile)
+	     (setq startfile (buffer-substring (point) (point-max)))
+	     (delete-region (point) (point-max))
+	     (comint-send-string proc startfile)))
+    (run-hooks 'comint-exec-hook)
+    buffer)))
+
+;;; This auxiliary function cranks up the process for comint-exec in
+;;; the appropriate environment. It is twice as long as it should be
+;;; because emacs has two distinct mechanisms for manipulating the
+;;; process environment, selected at compile time with the
+;;; MAINTAIN-ENVIRONMENT #define. In one case, process-environment
+;;; is bound; in the other it isn't.
+
+(defun comint-exec-1 (name buffer command switches)
+  (if (boundp 'process-environment) ; Not a completely reliable test.
+      (let ((process-environment
+	     (comint-update-env process-environment
+				(list (format "TERMCAP=emacs:co#%d:tc=unknown"
+					      (screen-width))
+				      "TERM=emacs"
+				      "EMACS=t"))))
+	(apply 'start-process name buffer command switches))
+
+      (let ((tcapv (getenv "TERMCAP"))
+	    (termv (getenv "TERM"))
+	    (emv   (getenv "EMACS")))
+	(unwind-protect
+	     (progn (setenv "TERMCAP" (format "emacs:co#%d:tc=unknown"
+					      (screen-width)))
+		    (setenv "TERM" "emacs")
+		    (setenv "EMACS" "t")
+		    (apply 'start-process name buffer command switches))
+	  (setenv "TERMCAP" tcapv)
+	  (setenv "TERM"    termv)
+	  (setenv "EMACS"   emv)))))
+	     
+
+
+;; This is just (append new old-env) that compresses out shadowed entries.
+;; It's also pretty ugly, mostly due to elisp's horrible iteration structures.
+(defun comint-update-env (old-env new)
+  (let ((ans (reverse new))
+	(vars (mapcar (function (lambda (vv)
+			(and (string-match "^[^=]*=" vv)
+			     (substring vv 0 (match-end 0)))))
+		      new)))
+    (while old-env
+      (let* ((vv (car old-env)) ; vv is var=value
+	     (var (and (string-match "^[^=]*=" vv)
+		       (substring vv 0 (match-end 0)))))
+	(setq old-env (cdr old-env))
+	(cond ((not (and var (comint-mem var vars)))
+	       (if var (setq var (cons var vars)))
+	       (setq ans (cons vv ans))))))
+    (nreverse ans)))
+
+;;; This should be in emacs, but it isn't.
+(defun comint-mem (item list &optional elt=)
+  "Test to see if ITEM is equal to an item in LIST.
+Option comparison function ELT= defaults to equal."
+  (let ((elt= (or elt= (function equal)))
+	(done nil))
+    (while (and list (not done))
+      (if (funcall elt= item (car list))
+	  (setq done list)
+	  (setq list (cdr list))))
+    done))
+
+
+;;; Ring Code
+;;;============================================================================
+;;; This code defines a ring data structure. A ring is a 
+;;;     (hd-index tl-index . vector) 
+;;; list. You can insert to, remove from, and rotate a ring. When the ring
+;;; fills up, insertions cause the oldest elts to be quietly dropped.
+;;;
+;;; HEAD = index of the newest item on the ring.
+;;; TAIL = index of the oldest item on the ring.
+;;;
+;;; These functions are used by the input history mechanism, but they can
+;;; be used for other purposes as well.
+
+(defun ring-p (x) 
+  "T if X is a ring; NIL otherwise."
+  (and (consp x) (integerp (car x))
+       (consp (cdr x)) (integerp (car (cdr x)))
+       (vectorp (cdr (cdr x)))))
+
+(defun make-ring (size)
+  "Make a ring that can contain SIZE elts"
+  (cons 1 (cons 0 (make-vector (+ size 1) nil))))
+
+(defun ring-plus1 (index veclen)
+  "INDEX+1, with wraparound"
+  (let ((new-index (+ index 1)))
+    (if (= new-index veclen) 0 new-index)))
+
+(defun ring-minus1 (index veclen)
+  "INDEX-1, with wraparound"
+  (- (if (= 0 index) veclen index) 1))
+
+(defun ring-length (ring)
+  "Number of elts in the ring."
+  (let ((hd (car ring)) (tl (car (cdr ring)))  (siz (length (cdr (cdr ring)))))
+    (let ((len (if (<= hd tl) (+ 1 (- tl hd)) (+ 1 tl (- siz hd)))))
+      (if (= len siz) 0 len))))
+
+(defun ring-empty-p (ring)
+  (= 0 (ring-length ring)))
+
+(defun ring-insert (ring item)
+  "Insert a new item onto the ring. If the ring is full, dump the oldest
+item to make room."       
+  (let* ((vec (cdr (cdr ring)))  (len (length vec))
+	 (new-hd (ring-minus1 (car ring) len)))
+      (setcar ring new-hd)
+      (aset vec new-hd item)
+      (if (ring-empty-p ring) ;overflow -- dump one off the tail.
+	  (setcar (cdr ring) (ring-minus1 (car (cdr ring)) len)))))
+
+(defun ring-remove (ring)
+  "Remove the oldest item retained on the ring."
+  (if (ring-empty-p ring) (error "Ring empty")
+      (let ((tl (car (cdr ring)))  (vec (cdr (cdr ring))))
+	(set-car (cdr ring) (ring-minus1 tl (length vec)))
+	(aref vec tl))))
+
+;;; This isn't actually used in this package. I just threw it in in case
+;;; someone else wanted it. If you want rotating-ring behavior on your history
+;;; retrieval (analagous to kill ring behavior), this function is what you
+;;; need. I should write the yank-input and yank-pop-input-or-kill to go with
+;;; this, and not bind it to a key by default, so it would be available to
+;;; people who want to bind it to a key. But who would want it? Blech.
+(defun ring-rotate (ring n)
+  (if (not (= n 0))
+      (if (ring-empty-p ring) ;Is this the right error check?
+	  (error "ring empty")
+	  (let ((hd (car ring))  (tl (car (cdr ring)))  (vec (cdr (cdr ring))))
+	    (let ((len (length vec)))
+	      (while (> n 0)
+		(setq tl (ring-plus1 tl len))
+		(aset ring tl (aref ring hd))
+		(setq hd (ring-plus1 hd len))
+		(setq n (- n 1)))
+	      (while (< n 0)
+		(setq hd (ring-minus1 hd len))
+		(aset vec hd (aref vec tl))
+		(setq tl (ring-minus1 tl len))
+		(setq n (- n 1))))
+	    (set-car ring hd)
+	    (set-car (cdr ring) tl)))))
+
+(defun comint-mod (n m)
+  "Returns N mod M. M is positive. Answer is guaranteed to be non-negative, 
+and less than m."
+  (let ((n (% n m)))
+    (if (>= n 0) n
+	(+ n
+	   (if (>= m 0) m (- m)))))) ; (abs m)
+
+(defun ring-ref (ring index)
+  (let ((numelts (ring-length ring)))
+    (if (= numelts 0) (error "indexed empty ring")
+	(let* ((hd (car ring))  (tl (car (cdr ring)))  (vec (cdr (cdr ring)))
+	       (index (comint-mod index numelts))
+	       (vec-index (comint-mod (+ index hd) 
+				      (length vec))))
+	  (aref vec vec-index)))))
+
+
+;;; Input history retrieval commands
+;;; M-p -- previous input    M-n -- next input
+;;; C-c r -- previous input matching
+;;; ===========================================================================
+
+(defun comint-previous-input (arg)
+  "Cycle backwards through input history."
+  (interactive "*p")
+  (let ((len (ring-length input-ring)))
+    (cond ((<= len 0)
+	   (message "Empty input ring")
+	   (ding))
+	  ((not (comint-after-pmark-p))
+	   (message "Not after process mark")
+	   (ding))
+	  (t
+	   (cond ((eq last-command 'comint-previous-input)
+		  (delete-region (mark) (point)))
+		 ((eq last-command 'comint-previous-similar-input)
+		  (delete-region 
+		   (process-mark (get-buffer-process (current-buffer)))
+		   (point)))
+		 (t                          
+		  (setq input-ring-index
+			(if (> arg 0) -1
+			    (if (< arg 0) 1 0)))
+		  (push-mark (point))))
+	   (setq input-ring-index (comint-mod (+ input-ring-index arg) len))
+	   (message "%d" (1+ input-ring-index))
+	   (insert (ring-ref input-ring input-ring-index))
+	   (setq this-command 'comint-previous-input)))))
+	 
+(defun comint-next-input (arg)
+  "Cycle forwards through input history."
+  (interactive "*p")
+  (comint-previous-input (- arg)))
+
+(defvar comint-last-input-match ""
+  "Last string searched for by comint input history search, for defaulting.
+Buffer local variable.") 
+
+(defun comint-previous-input-matching (str)
+  "Searches backwards through input history for substring match."
+  (interactive (let* ((last-command last-command) ; preserve around r-f-m
+		      (s (read-from-minibuffer 
+			 (format "Command substring (default %s): "
+				 comint-last-input-match))))
+		 (list (if (string= s "") comint-last-input-match s))))
+; (interactive "sCommand substring: ")
+  (setq comint-last-input-match str) ; update default
+  (if (not (eq last-command 'comint-previous-input))
+      (setq input-ring-index -1))
+  (let ((str (regexp-quote str))
+        (len (ring-length input-ring))
+	(n (+ input-ring-index 1)))
+    (while (and (< n len) (not (string-match str (ring-ref input-ring n))))
+      (setq n (+ n 1)))
+    (cond ((< n len)
+	   (comint-previous-input (- n input-ring-index)))
+	  (t (if (eq last-command 'comint-previous-input) 
+		 (setq this-command 'comint-previous-input))
+	     (message "Not found.")
+	     (ding)))))
+
+
+;;; These next three commands are alternatives to the input history commands
+;;; -- comint-next-input, comint-previous-input and
+;;; comint-previous-input-matching. They search through the process buffer
+;;; text looking for occurrences of the prompt.  Bound to M-P, M-N, and C-c R
+;;; (uppercase P, N, and R) for now. Try'em out. Go with what you like...
+
+;;; comint-msearch-input-matching prompts for a string, not a regexp.
+;;; This could be considered to be the wrong thing. I decided to keep it
+;;; simple, and not make the user worry about regexps. This, of course,
+;;; limits functionality.
+
+;;; These commands were deemed non-winning and have been commented out.
+;;; Feel free to re-enable them if you like. -Olin 3/91
+
+;(defun comint-psearch-input ()
+;  "Search forwards for next occurrence of prompt and skip to end of line.
+;\(prompt is anything matching regexp comint-prompt-regexp)"
+;  (interactive)
+;  (if (re-search-forward comint-prompt-regexp (point-max) t)
+;      (end-of-line)
+;      (error "No occurrence of prompt found")))
+;
+;(defun comint-msearch-input ()
+;  "Search backwards for previous occurrence of prompt and skip to end of line.
+;Search starts from beginning of current line."
+;  (interactive)
+;  (let ((p (save-excursion
+;	     (beginning-of-line)
+;	     (cond ((re-search-backward comint-prompt-regexp (point-min) t)
+;		    (end-of-line)
+;		    (point))
+;		   (t nil)))))
+;    (if p (goto-char p)
+;	(error "No occurrence of prompt found"))))
+;
+;(defun comint-msearch-input-matching (str)
+;  "Search backwards for occurrence of prompt followed by STRING.
+;STRING is prompted for, and is NOT a regular expression."
+;  (interactive (let ((s (read-from-minibuffer 
+;			 (format "Command (default %s): "
+;				 comint-last-input-match))))
+;		 (list (if (string= s "") comint-last-input-match s))))
+;; (interactive "sCommand: ")
+;  (setq comint-last-input-match str) ; update default
+;  (let* ((r (concat comint-prompt-regexp (regexp-quote str)))
+;	 (p (save-excursion
+;	      (beginning-of-line)
+;	      (cond ((re-search-backward r (point-min) t)
+;		     (end-of-line)
+;		     (point))
+;		    (t nil)))))
+;    (if p (goto-char p)
+;	(error "No match"))))
+
+;;;
+;;; Similar input -- contributed by ccm and highly winning.
+;;;
+;;; Reenter input, removing back to the last insert point if it exists. 
+;;;
+(defvar comint-last-similar-string "" 
+  "The string last used in a similar string search.")
+(defun comint-previous-similar-input (arg)
+  "Reenters the last input that matches the string typed so far.  If repeated 
+successively older inputs are reentered.  If arg is 1, it will go back
+in the history, if -1 it will go forward."
+  (interactive "p")
+  (if (not (comint-after-pmark-p))
+      (error "Not after process mark"))
+  (if (not (eq last-command 'comint-previous-similar-input))
+      (setq input-ring-index -1
+	    comint-last-similar-string 
+	    (buffer-substring 
+	     (process-mark (get-buffer-process (current-buffer)))
+	     (point))))
+  (let* ((size (length comint-last-similar-string))
+	 (len (ring-length input-ring))
+	 (n (+ input-ring-index arg))
+	 entry)
+    (while (and (< n len) 
+		(or (< (length (setq entry (ring-ref input-ring n))) size)
+		    (not (equal comint-last-similar-string 
+				(substring entry 0 size)))))
+      (setq n (+ n arg)))
+    (cond ((< n len)
+	   (setq input-ring-index n)
+	   (if (eq last-command 'comint-previous-similar-input)
+	       (delete-region (mark) (point)) ; repeat
+	       (push-mark (point)))	      ; 1st time
+	   (insert (substring entry size)))
+	  (t (message "Not found.") (ding) (sit-for 1)))
+    (message "%d" (1+ input-ring-index))))
+
+
+(defun comint-send-input () 
+  "Send input to process.  After the process output mark, sends all text
+from the process mark to point as input to the process.  Before the process
+output mark, calls value of variable comint-get-old-input to retrieve old
+input, copies it to the process mark, and sends it.  A terminal newline is
+also inserted into the buffer and sent to the process.  In either case, value
+of variable comint-input-sentinel is called on the input before sending it.
+The input is entered into the input history ring, if the value of variable
+comint-input-filter returns non-nil when called on the input.
+
+If variable comint-eol-on-send is non-nil, then point is moved to the end of
+line before sending the input.
+
+comint-get-old-input, comint-input-sentinel, and comint-input-filter are chosen
+according to the command interpreter running in the buffer. E.g.,
+If the interpreter is the csh,
+    comint-get-old-input is the default: take the current line, discard any
+        initial string matching regexp comint-prompt-regexp.
+    comint-input-sentinel monitors input for \"cd\", \"pushd\", and \"popd\" 
+        commands. When it sees one, it cd's the buffer.
+    comint-input-filter is the default: returns T if the input isn't all white
+	space.
+
+If the comint is Lucid Common Lisp, 
+    comint-get-old-input snarfs the sexp ending at point.
+    comint-input-sentinel does nothing.
+    comint-input-filter returns NIL if the input matches input-filter-regexp,
+        which matches (1) all whitespace (2) :a, :c, etc.
+
+Similarly for Soar, Scheme, etc.."
+  (interactive)
+  ;; Note that the input string does not include its terminal newline.
+  (let ((proc (get-buffer-process (current-buffer))))
+    (if (not proc) (error "Current buffer has no process")
+	(let* ((pmark (process-mark proc))
+	       (pmark-val (marker-position pmark))
+	       (input (if (>= (point) pmark-val)
+			  (progn (if comint-eol-on-send (end-of-line))
+				 (buffer-substring pmark (point)))
+			  (let ((copy (funcall comint-get-old-input)))
+			    (goto-char pmark)
+			    (insert copy)
+			    copy))))
+	  (insert ?\n)
+	  (if (funcall comint-input-filter input) (ring-insert input-ring input))
+	  (funcall comint-input-sentinel input)
+	  (funcall comint-input-sender proc input)
+	  (set-marker (process-mark proc) (point))
+	  (set-marker comint-last-input-end (point))))))
+
+(defun comint-get-old-input-default ()
+  "Default for comint-get-old-input: take the current line, and discard
+any initial text matching comint-prompt-regexp."
+  (save-excursion
+    (beginning-of-line)
+    (comint-skip-prompt)
+    (let ((beg (point)))
+      (end-of-line)
+      (buffer-substring beg (point)))))
+
+(defun comint-skip-prompt ()
+  "Skip past the text matching regexp comint-prompt-regexp. 
+If this takes us past the end of the current line, don't skip at all."
+  (let ((eol (save-excursion (end-of-line) (point))))
+    (if (and (looking-at comint-prompt-regexp)
+	     (<= (match-end 0) eol))
+	(goto-char (match-end 0)))))
+
+
+(defun comint-after-pmark-p ()
+  "Is point after the process output marker?"
+  ;; Since output could come into the buffer after we looked at the point
+  ;; but before we looked at the process marker's value, we explicitly 
+  ;; serialise. This is just because I don't know whether or not emacs
+  ;; services input during execution of lisp commands.
+  (let ((proc-pos (marker-position
+		   (process-mark (get-buffer-process (current-buffer))))))
+    (<= proc-pos (point))))
+
+(defun comint-simple-send (proc string)
+  "Default function for sending to PROC input STRING.
+This just sends STRING plus a newline. To override this,
+set the hook COMINT-INPUT-SENDER."
+  (comint-send-string proc string)
+  (comint-send-string proc "\n"))
+
+(defun comint-bol (arg)
+  "Goes to the beginning of line, then skips past the prompt, if any.
+If a prefix argument is given (\\[universal-argument]), then no prompt skip 
+-- go straight to column 0.
+
+The prompt skip is done by skipping text matching the regular expression
+comint-prompt-regexp, a buffer local variable.
+
+If you don't like this command, reset c-a to beginning-of-line 
+in your hook, comint-mode-hook."
+  (interactive "P")
+  (beginning-of-line)
+  (if (null arg) (comint-skip-prompt)))
+
+;;; These two functions are for entering text you don't want echoed or
+;;; saved -- typically passwords to ftp, telnet, or somesuch.
+;;; Just enter m-x send-invisible and type in your line.
+
+(defun comint-read-noecho (prompt)
+  "Prompt the user with argument PROMPT. Read a single line of text
+without echoing, and return it. Note that the keystrokes comprising
+the text can still be recovered (temporarily) with \\[view-lossage]. This
+may be a security bug for some applications."
+  (let ((echo-keystrokes 0)
+	(answ "")
+	tem)
+    (if (and (stringp prompt) (not (string= (message prompt) "")))
+	(message prompt))
+    (while (not(or  (= (setq tem (read-char)) ?\^m)
+		    (= tem ?\n)))
+      (setq answ (concat answ (char-to-string tem))))
+    (message "")
+    answ))
+
+(defun send-invisible (str)
+  "Read a string without echoing, and send it to the process running
+in the current buffer. A new-line is additionally sent. String is not 
+saved on comint input history list.
+Security bug: your string can still be temporarily recovered with
+\\[view-lossage]."
+; (interactive (list (comint-read-noecho "Enter non-echoed text")))
+  (interactive "P") ; Defeat snooping via C-x esc
+  (let ((proc (get-buffer-process (current-buffer))))
+    (if (not proc) (error "Current buffer has no process")
+	(comint-send-string proc
+			    (if (stringp str) str
+				(comint-read-noecho "Enter non-echoed text")))
+	(comint-send-string proc "\n"))))
+
+
+;;; Low-level process communication
+
+(defvar comint-input-chunk-size 512
+  "*Long inputs send to comint processes are broken up into chunks of this size.
+If your process is choking on big inputs, try lowering the value.")
+
+(defun comint-send-string (proc str)
+  "Send PROCESS the contents of STRING as input.
+This is equivalent to process-send-string, except that long input strings
+are broken up into chunks of size comint-input-chunk-size. Processes
+are given a chance to output between chunks. This can help prevent processes
+from hanging when you send them long inputs on some OS's."
+  (let* ((len (length str))
+	 (i (min len comint-input-chunk-size)))
+    (process-send-string proc (substring str 0 i))
+    (while (< i len)
+      (let ((next-i (+ i comint-input-chunk-size)))
+	(accept-process-output)
+	(process-send-string proc (substring str i (min len next-i)))
+	(setq i next-i)))))
+
+(defun comint-send-region (proc start end)
+  "Sends to PROC the region delimited by START and END.
+This is a replacement for process-send-region that tries to keep
+your process from hanging on long inputs. See comint-send-string."
+  (comint-send-string proc (buffer-substring start end)))
+
+
+;;; Random input hackage
+
+(defun comint-kill-output ()
+  "Kill all output from interpreter since last input."
+  (interactive)
+  (let ((pmark (process-mark (get-buffer-process (current-buffer)))))
+    (kill-region comint-last-input-end pmark)
+    (goto-char pmark)    
+    (insert "*** output flushed ***\n")
+    (set-marker pmark (point))))
+
+(defun comint-show-output ()
+  "Display start of this batch of interpreter output at top of window.
+Also put cursor there."
+  (interactive)
+  (goto-char comint-last-input-end)
+  (backward-char)
+  (beginning-of-line)
+  (set-window-start (selected-window) (point))
+  (end-of-line))
+
+(defun comint-interrupt-subjob ()
+  "Interrupt the current subjob."
+  (interactive)
+  (interrupt-process nil comint-ptyp))
+
+(defun comint-kill-subjob ()
+  "Send kill signal to the current subjob."
+  (interactive)
+  (kill-process nil comint-ptyp))
+
+(defun comint-quit-subjob ()
+  "Send quit signal to the current subjob."
+  (interactive)
+  (quit-process nil comint-ptyp))
+
+(defun comint-stop-subjob ()
+  "Stop the current subjob.
+WARNING: if there is no current subjob, you can end up suspending
+the top-level process running in the buffer. If you accidentally do
+this, use \\[comint-continue-subjob] to resume the process. (This
+is not a problem with most shells, since they ignore this signal.)"
+  (interactive)
+  (stop-process nil comint-ptyp))
+
+(defun comint-continue-subjob ()
+  "Send CONT signal to process buffer's process group.
+Useful if you accidentally suspend the top-level process."
+  (interactive)
+  (continue-process nil comint-ptyp))
+
+(defun comint-kill-input ()
+  "Kill all text from last stuff output by interpreter to point."
+  (interactive)
+  (let* ((pmark (process-mark (get-buffer-process (current-buffer))))
+	 (p-pos (marker-position pmark)))
+    (if (> (point) p-pos)
+	(kill-region pmark (point)))))
+
+(defun comint-delchar-or-maybe-eof (arg)
+  "Delete ARG characters forward, or send an EOF to process if at end of buffer."
+  (interactive "p")
+  (if (eobp)
+      (process-send-eof)
+      (delete-char arg)))
+
+
+
+
+;;; Support for source-file processing commands.
+;;;============================================================================
+;;; Many command-interpreters (e.g., Lisp, Scheme, Soar) have
+;;; commands that process files of source text (e.g. loading or compiling
+;;; files). So the corresponding process-in-a-buffer modes have commands
+;;; for doing this (e.g., lisp-load-file). The functions below are useful
+;;; for defining these commands.
+;;;
+;;; Alas, these guys don't do exactly the right thing for Lisp, Scheme
+;;; and Soar, in that they don't know anything about file extensions.
+;;; So the compile/load interface gets the wrong default occasionally.
+;;; The load-file/compile-file default mechanism could be smarter -- it
+;;; doesn't know about the relationship between filename extensions and
+;;; whether the file is source or executable. If you compile foo.lisp
+;;; with compile-file, then the next load-file should use foo.bin for
+;;; the default, not foo.lisp. This is tricky to do right, particularly
+;;; because the extension for executable files varies so much (.o, .bin,
+;;; .lbin, .mo, .vo, .ao, ...).
+
+
+;;; COMINT-SOURCE-DEFAULT -- determines defaults for source-file processing
+;;; commands.
+;;;
+;;; COMINT-CHECK-SOURCE -- if FNAME is in a modified buffer, asks you if you
+;;; want to save the buffer before issuing any process requests to the command
+;;; interpreter.
+;;;
+;;; COMINT-GET-SOURCE -- used by the source-file processing commands to prompt
+;;; for the file to process.
+
+;;; (COMINT-SOURCE-DEFAULT previous-dir/file source-modes)
+;;;============================================================================
+;;; This function computes the defaults for the load-file and compile-file
+;;; commands for tea, soar, cmulisp, and cmuscheme modes. 
+;;; 
+;;; - PREVIOUS-DIR/FILE is a pair (directory . filename) from the last 
+;;; source-file processing command. NIL if there hasn't been one yet.
+;;; - SOURCE-MODES is a list used to determine what buffers contain source
+;;; files: if the major mode of the buffer is in SOURCE-MODES, it's source.
+;;; Typically, (lisp-mode) or (scheme-mode).
+;;; 
+;;; If the command is given while the cursor is inside a string, *and*
+;;; the string is an existing filename, *and* the filename is not a directory,
+;;; then the string is taken as default. This allows you to just position
+;;; your cursor over a string that's a filename and have it taken as default.
+;;;
+;;; If the command is given in a file buffer whose major mode is in
+;;; SOURCE-MODES, then the the filename is the default file, and the
+;;; file's directory is the default directory.
+;;; 
+;;; If the buffer isn't a source file buffer (e.g., it's the process buffer),
+;;; then the default directory & file are what was used in the last source-file
+;;; processing command (i.e., PREVIOUS-DIR/FILE).  If this is the first time
+;;; the command has been run (PREVIOUS-DIR/FILE is nil), the default directory
+;;; is the cwd, with no default file. (\"no default file\" = nil)
+;;; 
+;;; SOURCE-REGEXP is typically going to be something like (tea-mode)
+;;; for T programs, (lisp-mode) for Lisp programs, (soar-mode lisp-mode)
+;;; for Soar programs, etc.
+;;; 
+;;; The function returns a pair: (default-directory . default-file).
+
+(defun comint-source-default (previous-dir/file source-modes)
+  (cond ((and buffer-file-name (memq major-mode source-modes))
+	 (cons (file-name-directory    buffer-file-name)
+	       (file-name-nondirectory buffer-file-name)))
+	(previous-dir/file)
+	(t
+	 (cons default-directory nil))))
+
+
+;;; (COMINT-CHECK-SOURCE fname)
+;;;============================================================================
+;;; Prior to loading or compiling (or otherwise processing) a file (in the CMU
+;;; process-in-a-buffer modes), this function can be called on the filename.
+;;; If the file is loaded into a buffer, and the buffer is modified, the user
+;;; is queried to see if he wants to save the buffer before proceeding with
+;;; the load or compile.
+
+(defun comint-check-source (fname)
+  (let ((buff (get-file-buffer fname)))
+    (if (and buff
+	     (buffer-modified-p buff)
+	     (y-or-n-p (format "Save buffer %s first? "
+			       (buffer-name buff))))
+	;; save BUFF.
+	(let ((old-buffer (current-buffer)))
+	  (set-buffer buff)
+	  (save-buffer)
+	  (set-buffer old-buffer)))))
+
+
+;;; (COMINT-GET-SOURCE prompt prev-dir/file source-modes mustmatch-p)
+;;;============================================================================
+;;; COMINT-GET-SOURCE is used to prompt for filenames in command-interpreter
+;;; commands that process source files (like loading or compiling a file).
+;;; It prompts for the filename, provides a default, if there is one,
+;;; and returns the result filename.
+;;; 
+;;; See COMINT-SOURCE-DEFAULT for more on determining defaults.
+;;; 
+;;; PROMPT is the prompt string. PREV-DIR/FILE is the (directory . file) pair
+;;; from the last source processing command.  SOURCE-MODES is a list of major
+;;; modes used to determine what file buffers contain source files.  (These
+;;; two arguments are used for determining defaults). If MUSTMATCH-P is true,
+;;; then the filename reader will only accept a file that exists.
+;;; 
+;;; A typical use:
+;;; (interactive (comint-get-source "Compile file: " prev-lisp-dir/file
+;;;                                 '(lisp-mode) t))
+
+;;; This is pretty stupid about strings. It decides we're in a string
+;;; if there's a quote on both sides of point on the current line.
+(defun comint-extract-string ()
+  "Returns string around point that starts the current line or nil." 
+  (save-excursion
+    (let* ((point (point))
+	   (bol (progn (beginning-of-line) (point)))
+	   (eol (progn (end-of-line) (point)))
+	   (start (progn (goto-char point) 
+			 (and (search-backward "\"" bol t) 
+			      (1+ (point)))))
+	   (end (progn (goto-char point)
+		       (and (search-forward "\"" eol t)
+			    (1- (point))))))
+      (and start end
+	   (buffer-substring start end)))))
+
+(defun comint-get-source (prompt prev-dir/file source-modes mustmatch-p)
+  (let* ((def (comint-source-default prev-dir/file source-modes))
+         (stringfile (comint-extract-string))
+	 (sfile-p (and stringfile
+		       (condition-case ()
+			   (file-exists-p stringfile)
+			 (error nil))
+		       (not (file-directory-p stringfile))))
+	 (defdir  (if sfile-p (file-name-directory stringfile)
+                      (car def)))
+	 (deffile (if sfile-p (file-name-nondirectory stringfile)
+                      (cdr def)))
+	 (ans (read-file-name (if deffile (format "%s(default %s) "
+						  prompt    deffile)
+				  prompt)
+			      defdir
+			      (concat defdir deffile)
+			      mustmatch-p)))
+    (list (expand-file-name (substitute-in-file-name ans)))))
+
+;;; I am somewhat divided on this string-default feature. It seems
+;;; to violate the principle-of-least-astonishment, in that it makes
+;;; the default harder to predict, so you actually have to look and see
+;;; what the default really is before choosing it. This can trip you up.
+;;; On the other hand, it can be useful, I guess. I would appreciate feedback
+;;; on this.
+;;;     -Olin
+
+
+;;; Simple process query facility.
+;;; ===========================================================================
+;;; This function is for commands that want to send a query to the process
+;;; and show the response to the user. For example, a command to get the
+;;; arglist for a Common Lisp function might send a "(arglist 'foo)" query
+;;; to an inferior Common Lisp process.
+;;; 
+;;; This simple facility just sends strings to the inferior process and pops
+;;; up a window for the process buffer so you can see what the process
+;;; responds with.  We don't do anything fancy like try to intercept what the
+;;; process responds with and put it in a pop-up window or on the message
+;;; line. We just display the buffer. Low tech. Simple. Works good.
+
+;;; Send to the inferior process PROC the string STR. Pop-up but do not select
+;;; a window for the inferior process so that its response can be seen.
+(defun comint-proc-query (proc str)
+  (let* ((proc-buf (process-buffer proc))
+	 (proc-mark (process-mark proc)))
+    (display-buffer proc-buf)
+    (set-buffer proc-buf) ; but it's not the selected *window*
+    (let ((proc-win (get-buffer-window proc-buf))
+	  (proc-pt (marker-position proc-mark)))
+      (comint-send-string proc str) ; send the query
+      (accept-process-output proc)  ; wait for some output
+      ;; Try to position the proc window so you can see the answer.
+      ;; This is bogus code. If you delete the (sit-for 0), it breaks.
+      ;; I don't know why. Wizards invited to improve it.
+      (if (not (pos-visible-in-window-p proc-pt proc-win))
+	  (let ((opoint (window-point proc-win)))
+	    (set-window-point proc-win proc-mark) (sit-for 0)
+	    (if (not (pos-visible-in-window-p opoint proc-win))
+		(push-mark opoint)
+		(set-window-point proc-win opoint)))))))
+
+
+;;; Filename completion in a buffer
+;;; ===========================================================================
+;;; Useful completion functions, courtesy of the Ergo group.
+;;; M-<Tab> will complete the filename at the cursor as much as possible
+;;; M-? will display a list of completions in the help buffer.
+
+;;; Three commands:
+;;; comint-dynamic-complete		Complete filename at point.
+;;; comint-dynamic-list-completions	List completions in help buffer.
+;;; comint-replace-by-expanded-filename	Expand and complete filename at point;
+;;;					replace with expanded/completed name.
+
+;;; These are not installed in the comint-mode keymap. But they are
+;;; available for people who want them. Shell-mode installs them:
+;;; (define-key cmushell-mode-map "\M-\t" 'comint-dynamic-complete)
+;;; (define-key cmushell-mode-map "\M-?"  'comint-dynamic-list-completions)))
+;;;
+;;; Commands like this are fine things to put in load hooks if you
+;;; want them present in specific modes. Example:
+;;; (setq cmushell-load-hook
+;;;       '((lambda () (define-key lisp-mode-map "\M-\t"
+;;;				   'comint-replace-by-expanded-filename))))
+;;;          
+
+
+(defun comint-match-partial-pathname ()
+  "Returns the filename at point or causes an error."
+  (save-excursion
+    (if (re-search-backward "[^~/A-Za-z0-9---_.$#,=]" nil 'move)
+	(forward-char 1))
+    ;; Anchor the search forwards.
+    (if (not (looking-at "[~/A-Za-z0-9---_.$#,=]")) (error ""))
+    (re-search-forward "[~/A-Za-z0-9---_.$#,=]+")
+    (substitute-in-file-name
+     (buffer-substring (match-beginning 0) (match-end 0)))))
+
+
+(defun comint-replace-by-expanded-filename ()
+"Replace the filename at point with an expanded, canonicalised, and
+completed replacement.
+\"Expanded\" means environment variables (e.g., $HOME) and ~'s are
+replaced with the corresponding directories.  \"Canonicalised\" means ..
+and \. are removed, and the filename is made absolute instead of relative.
+See functions expand-file-name and substitute-in-file-name. See also
+comint-dynamic-complete."
+  (interactive)
+  (let* ((pathname (comint-match-partial-pathname))
+	 (pathdir (file-name-directory pathname))
+	 (pathnondir (file-name-nondirectory pathname))
+	 (completion (file-name-completion pathnondir
+					   (or pathdir default-directory))))
+    (cond ((null completion)
+	   (message "No completions of %s." pathname)
+	   (ding))
+	  ((eql completion t)
+	   (message "Unique completion."))
+	  (t				; this means a string was returned.
+	   (delete-region (match-beginning 0) (match-end 0))
+	   (insert (expand-file-name (concat pathdir completion)))))))
+
+
+(defun comint-dynamic-complete ()
+  "Dynamically complete the filename at point.
+This function is similar to comint-replace-by-expanded-filename, except
+that it won't change parts of the filename already entered in the buffer; 
+it just adds completion characters to the end of the filename."
+  (interactive)
+  (let* ((pathname (comint-match-partial-pathname))
+	 (pathdir (file-name-directory pathname))
+	 (pathnondir (file-name-nondirectory pathname))
+	 (completion (file-name-completion  pathnondir
+					   (or pathdir default-directory))))
+    (cond ((null completion)
+	   (message "No completions of %s." pathname)
+	   (ding))
+	  ((eql completion t)
+	   (message "Unique completion."))
+	  (t				; this means a string was returned.
+	   (goto-char (match-end 0))
+	   (insert (substring completion (length pathnondir)))))))
+
+(defun comint-dynamic-list-completions ()
+  "List in help buffer all possible completions of the filename at point."
+  (interactive)
+  (let* ((pathname (comint-match-partial-pathname))
+	 (pathdir (file-name-directory pathname))
+	 (pathnondir (file-name-nondirectory pathname))
+	 (completions
+	  (file-name-all-completions pathnondir
+				     (or pathdir default-directory))))
+    (cond ((null completions)
+	   (message "No completions of %s." pathname)
+	   (ding))
+	  (t
+	   (let ((conf (current-window-configuration)))
+	     (with-output-to-temp-buffer "*Help*"
+	       (display-completion-list completions))
+	     (sit-for 0)
+	     (message "Hit space to flush.")
+	     (let ((ch (read-char)))
+	       (if (= ch ?\ )
+		   (set-window-configuration conf)
+		   (setq unread-command-char ch))))))))
+
+; Ergo bindings
+; (global-set-key "\M-\t" 'comint-replace-by-expanded-filename)
+; (global-set-key "\M-?" 'comint-dynamic-list-completions)
+; (define-key shell-mode-map "\M-\t" 'comint-dynamic-complete)
+
+;;; Converting process modes to use comint mode
+;;; ===========================================================================
+;;; Several gnu packages (tex-mode, background, dbx, gdb, kermit, prolog, 
+;;; telnet are some) use the shell package as clients. Most of them would
+;;; be better off using the comint package, but they predate it. 
+;;;
+;;; Altering these packages to use comint mode should greatly
+;;; improve their functionality, and is fairly easy.
+;;; 
+;;; Renaming variables
+;;; Most of the work is renaming variables and functions. These are the common
+;;; ones:
+;;; Local variables:
+;;; 	last-input-end		comint-last-input-end
+;;;	last-input-start	<unnecessary>
+;;;	shell-prompt-pattern	comint-prompt-regexp
+;;;     shell-set-directory-error-hook <no equivalent>
+;;; Miscellaneous:
+;;;	shell-set-directory	<unnecessary>
+;;; 	shell-mode-map		comint-mode-map
+;;; Commands:
+;;;	shell-send-input	comint-send-input
+;;;	shell-send-eof		comint-delchar-or-maybe-eof
+;;; 	kill-shell-input	comint-kill-input
+;;;	interrupt-shell-subjob	comint-interrupt-subjob
+;;;	stop-shell-subjob	comint-stop-subjob
+;;;	quit-shell-subjob	comint-quit-subjob
+;;;	kill-shell-subjob	comint-kill-subjob
+;;;	kill-output-from-shell	comint-kill-output
+;;;	show-output-from-shell	comint-show-output
+;;;	copy-last-shell-input	Use comint-previous-input/comint-next-input
+;;;
+;;; LAST-INPUT-START is no longer necessary because inputs are stored on the
+;;; input history ring. SHELL-SET-DIRECTORY is gone, its functionality taken
+;;; over by SHELL-DIRECTORY-TRACKER, the shell mode's comint-input-sentinel.
+;;; Comint mode does not provide functionality equivalent to 
+;;; shell-set-directory-error-hook; it is gone.
+;;; 
+;;; If you are implementing some process-in-a-buffer mode, called foo-mode, do
+;;; *not* create the comint-mode local variables in your foo-mode function.
+;;; This is not modular.  Instead, call comint-mode, and let *it* create the
+;;; necessary comint-specific local variables. Then create the
+;;; foo-mode-specific local variables in foo-mode.  Set the buffer's keymap to
+;;; be foo-mode-map, and its mode to be foo-mode.  Set the comint-mode hooks
+;;; (comint-prompt-regexp, comint-input-filter, comint-input-sentinel,
+;;; comint-get-old-input) that need to be different from the defaults.  Call
+;;; foo-mode-hook, and you're done. Don't run the comint-mode hook yourself;
+;;; comint-mode will take care of it. The following example, from cmushell.el,
+;;; is typical:
+;;; 
+;;; (defun shell-mode ()
+;;;   (interactive)
+;;;   (comint-mode)
+;;;   (setq comint-prompt-regexp shell-prompt-pattern)
+;;;   (setq major-mode 'shell-mode)
+;;;   (setq mode-name "Shell")
+;;;   (cond ((not shell-mode-map)
+;;; 	     (setq shell-mode-map (full-copy-sparse-keymap comint-mode-map))
+;;; 	     (define-key shell-mode-map "\M-\t" 'comint-dynamic-complete)
+;;; 	     (define-key shell-mode-map "\M-?"
+;;;                      'comint-dynamic-list-completions)))
+;;;   (use-local-map shell-mode-map)
+;;;   (make-local-variable 'shell-directory-stack)
+;;;   (setq shell-directory-stack nil)
+;;;   (setq comint-input-sentinel 'shell-directory-tracker)
+;;;   (run-hooks 'shell-mode-hook))
+;;;
+;;;
+;;; Note that make-comint is different from make-shell in that it
+;;; doesn't have a default program argument. If you give make-shell
+;;; a program name of NIL, it cleverly chooses one of explicit-shell-name,
+;;; $ESHELL, $SHELL, or /bin/sh. If you give make-comint a program argument
+;;; of NIL, it barfs. Adjust your code accordingly...
+;;;
+
+;;; Do the user's customisation...
+
+(defvar comint-load-hook nil
+  "This hook is run when comint is loaded in.
+This is a good place to put keybindings.")
+	
+(run-hooks 'comint-load-hook)
+
+;;; Change log:
+;;; 9/12/89 
+;;;  - Souped up the filename expansion procedures.
+;;;    Doc strings are much clearer and more detailed.
+;;;    Fixed a bug where doing a filename completion when the point
+;;;    was in the middle of the filename instead of at the end would lose.
+;;;
+;;; 2/17/90 
+;;;  - Souped up the command history stuff so that text inserted
+;;;    by comint-previous-input-matching is removed by following
+;;;    command history recalls. comint-next/previous-input-matching
+;;;    is now much more smoothly integrated w/the command history stuff.
+;;;  - Added comint-eol-on-send flag and comint-input-sender hook.
+;;;    Comint-input-sender based on code contributed by Jeff Peck
+;;;    (peck@sun.com).
+;;;
+;;; 3/13/90 ccm@cmu.cs.edu
+;;;  - Added comint-previous-similar-input for looking up similar inputs.
+;;;  - Added comint-send-and-get-output to allow snarfing input from
+;;;    buffer. 
+;;;  - Added the ability to pick up a source file by positioning over
+;;;    a string in comint-get-source.
+;;;  - Added add-hook to make it a little easier for the user to use
+;;;    multiple hooks.
+;;;  
+;;; 5/22/90 shivers
+;;; - Moved Chris' multiplexed ipc stuff to comint-ipc.el.
+;;; - Altered Chris' comint-get-source string feature. The string
+;;;   is only offered as a default if it names an existing file.
+;;; - Changed comint-exec to directly crank up the process, instead
+;;;   of calling the env program. This made background.el happy.
+;;; - Added new buffer-local var comint-ptyp. The problem is that
+;;;   the signalling functions don't work as advertised. If you are
+;;;   communicating via pipes, the CURRENT-GROUP arg is supposed to
+;;;   be ignored, but, unfortunately it seems to be the case that you
+;;;   must pass a NIL for this arg in the pipe case. COMINT-PTYP
+;;;   is a flag that tells whether the process is communicating
+;;;   via pipes or a pty. The comint signalling functions use it
+;;;   to determine the necessary CURRENT-GROUP arg value. The bug
+;;;   has been reported to the Gnu folks.
+;;; - comint-dynamic-complete flushes the help window if you hit space
+;;;   after you execute it.
+;;; - Added functions comint-send-string, comint-send-region and var 
+;;;   comint-input-chunk-size.  comint-send-string tries to prevent processes
+;;;   from hanging when you send them long strings by breaking them into
+;;;   chunks and allowing process output between chunks. I got the idea from
+;;;   Eero Simoncelli's Common Lisp package. Note that using
+;;;   comint-send-string means that the process buffer's contents can change
+;;;   during a call!  If you depend on process output only happening between
+;;;   toplevel commands, this could be a problem. In such a case, use
+;;;   process-send-string instead. If this is a problem for people, I'd like
+;;;   to hear about it.
+;;; - Added comint-proc-query as a simple mechanism for commands that
+;;;   want to query an inferior process and display its response. For a
+;;;   typical use, see lisp-show-arglist in cmulisp.el.
+;;; - Added constant comint-version, which is now "2.01".
+;;;
+;;; 6/14/90 shivers
+;;; - Had comint-update-env defined twice. Removed extra copy. Also
+;;;   renamed mem to be comint-mem, for modularity. The duplication
+;;;   was reported by Michael Meissner.
+;;; 6/16/90 shivers
+;;; - Emacs has two different mechanisms for maintaining the process
+;;;   environment, determined at compile time by the MAINTAIN-ENVIRONMENT
+;;;   #define. One uses the process-environment global variable, and
+;;;   one uses a getenv/setenv interface. comint-exec assumed the
+;;;   process-environment interface; it has been generalised (with
+;;;   comint-exec-1) to handle both cases. Pretty bogus. We could,
+;;;   of course, skip all this and just use the etc/env program to
+;;;   handle the environment tweaking, but that obscures process
+;;;   queries that other modules (like background.el) depend on. etc/env
+;;;   is also fairly bogus. This bug, and some of the fix code was
+;;;   reported by Dan Pierson.
+;;;
+;;; 9/5/90 shivers
+;;; - Changed make-variable-buffer-local's to make-local-variable's.
+;;;   This leaves non-comint-mode buffers alone. Stephane Payrard
+;;;   reported the sloppy useage.
+;;; - You can now go from comint-previous-similar-input to
+;;;   comint-previous-input with no problem.
+;;;
+;;; 12/21/90 shivers
+;;; - Added a condition-case to comint-get-source. Bogus strings
+;;;   beginning with ~ were making the file-exists-p barf.
+;;; - Added "=" to the set of chars recognised by file completion
+;;;   as constituting a filename.
+;;;
+;;; 1/90 shivers
+;;; These changes comprise release 2.02:
+;;; - Removed the kill-all-local-variables in comint-mode. This
+;;;   made it impossible for client modes to set things before calling
+;;;   comint-mode. (In particular, it messed up ilisp.el) In general,
+;;;   the client mode should be responsible for a k-a-l-v's.
+;;; - Fixed comint-match-partial-pathname so that it works in
+;;;   more cases: if the filename begins at the start-of-buffer;
+;;;   if point is on the first char of the filename. Just a question
+;;;   of getting the tricky bits right.
+;;; - Added a hook, comint-exec-hook that is run each time a process
+;;;   is cranked up. Useful for things like process-kill-without-query.
+;;;
+;;; These two were pointed out by tale:
+;;; - Improved the doc string in comint-send-input a little bit.
+;;; - Tweaked make-comint to check process status with comint-check-proc
+;;;   instead of equivalent inline code. 
+;;;
+;;; - Prompt-search history commands have been commented out. I never
+;;;   liked them; I don't think anyone used them.
+;;; - Made comint-exec-hook a local var, as it should have been.
+;;;   (This way, for instance, you can have cmushell procs kill-w/o-query,
+;;;    but let Scheme procs be default.)
diff --git a/emacs/jar-hacks.el b/emacs/jar-hacks.el
new file mode 100644
index 0000000..4fdf572
--- /dev/null
+++ b/emacs/jar-hacks.el
@@ -0,0 +1,91 @@
+
+; Comment out region
+
+(defun comment-out-region (arg)
+  "Insert comment string at beginning of each line in the region."
+  (interactive "P")
+  (let (start end)
+    (if (< (point) (mark))
+        (setq start (point) end (mark-marker))
+        (setq start (mark) end (point-marker)))
+    (save-excursion
+      (untabify start (marker-position end))
+      (goto-char start)
+      (if (not (bolp))
+	  (progn (end-of-line) (forward-char)))
+      (while (< (point) (marker-position end))
+	(if (eq arg '-)
+	    (if (looking-at comment-start)
+		(delete-char (length comment-start)))
+	    (insert comment-start))
+	(end-of-line)
+	(forward-char)))))
+
+;(defun uncomment-out-region (arg)
+;  (interactive nil)
+;  (comment-out-region '-))
+
+
+; Mini-Find Tag
+
+(defvar last-mini-tag "" "Last tag sought by mini-find-tag.")
+
+(defun mini-find-tag (tagname &optional next)
+  "Search for a definition of TAGNAME in current buffer.
+ If TAGNAME is a null string, the expression in the buffer
+around or before point is used as the tag name.
+ If second arg NEXT is non-nil (interactively, with prefix arg),
+searches for the next definition in the buffer
+that matches the tag name used in the previous mini-find-tag."
+
+  (interactive (if current-prefix-arg
+		   '(nil t)
+		 (list (read-string "Mini-find tag: "))))
+  (if (equal tagname "")             ;See definition of find-tag.
+      (setq tagname (save-excursion
+		      (buffer-substring
+		       (progn (backward-sexp 1) (point))
+		       (progn (forward-sexp 1) (point))))))
+  (let ((pt (save-excursion
+	      (if (not next)
+		  (goto-char (point-min))
+		(setq tagname last-mini-tag))
+	      (setq last-mini-tag tagname)
+	      (if (re-search-forward
+		     (concat "^(def.*" tagname)
+		     nil t)
+		  (point)
+		nil))))
+    (if pt
+	(progn (set-mark-command nil)
+	       (goto-char pt))
+      (signal 'search-failed '()))))
+
+; indent-differently
+
+(defun indent-differently ()
+  "Make the current line indent like the body of a special form by
+changing the operator's scheme-indent-hook appropriately."
+  (interactive nil)
+  (let ((here (point)))
+    (save-excursion
+      (back-to-indentation)
+      (backward-up-list 1)
+      (forward-char 1)
+      (let ((i -1)
+	    (function nil)
+	    (p (point)))
+	(while (<= (point) here)
+	  (setq i (+ i 1))
+	  (forward-sexp 1)
+	  (if (= i 0)
+	      (setq function (buffer-substring p (point)))))
+	(setq i (- i 1))
+	(let ((name (intern (downcase function))))
+	  (cond ((equal (get name 'scheme-indent-hook) i)
+		 (message "Indent %s nil" name)
+		 (put name 'scheme-indent-hook nil))
+		(t
+		 (message "Indent %s %d" name i)
+		 (put name 'scheme-indent-hook i))))))
+    (scheme-indent-line)))
diff --git a/gdbinit b/gdbinit
new file mode 100644
index 0000000..db62987
--- /dev/null
+++ b/gdbinit
@@ -0,0 +1,98 @@
+#
+# Commands useful for debugging the Scheme48 VM.
+#
+
+#Set a breakpoint at label "raise".
+#Obtain the proper line number using "egrep -n raise: scheme48vm.c".
+break scheme48vm.c:5227
+
+display/i $pc
+
+define pcont
+echo template id = \ 
+output *(long *)((*(long *)(($ & ~3) + 8) & ~3) + 4) / 4
+echo \npc = \ 
+output (*(long *)(($ & ~3) + 4) / 4)
+echo \nparent = \ 
+output *(long *)($ & ~3)
+echo \nenv = \ 
+output *(long *)(($ & ~3) + 12)
+echo \ncount = \ 
+output *(long *)(($ & ~3) - 4) >> 10
+echo \n
+end
+#
+document pcont
+Print $ as a continuation.
+end
+
+
+define parent
+print *(long *)($ & ~3)
+pcont
+end
+#
+document parent
+Select parent continuation.
+end
+
+
+define preview
+set $cont = ScontS
+preview-loop
+end
+#
+define preview-loop
+output $cont
+echo \040
+output *(long *)((*(long *)(($cont & ~3) + 8) & ~3) + 4) / 4
+echo \n
+set $cont = *(long *)($cont & ~3)
+preview-loop
+end
+#
+document preview
+Display Scheme stack trace.  Look up the template uids in the .debug file.
+end
+
+
+define show-header
+echo Header length:\ 
+output $hdr >> 8
+echo \ type:\040
+output ($hdr & 127) >> 2
+echo \ tag:\040
+output $hdr & 3
+echo \n
+end
+
+define look
+output ($ - Snewspace_beginS)
+echo :\n
+set $hdr = *(long *)($ - 7)
+show-header
+output *(long *)($ - 3)
+echo \n
+output *(long *)($ + 1)
+echo \n
+output *(long *)($ + 5)
+echo \n
+end
+
+define go0
+print *(long *)($ - 3)
+end
+
+define bytes
+set $foo = RScode_pointerS
+output (int)*(unsigned char *)($foo + 0)
+echo \040
+output (int)*(unsigned char *)($foo + 1)
+echo \040
+output (int)*(unsigned char *)($foo + 2)
+echo \040
+output (int)*(unsigned char *)($foo + 3)
+echo \040
+output (int)*(unsigned char *)($foo + 4)
+echo \n
+end
diff --git a/install-sh b/install-sh
new file mode 100755
index 0000000..5871924
--- /dev/null
+++ b/install-sh
@@ -0,0 +1,238 @@
+#! /bin/sh
+#
+# install - install a program, script, or datafile
+# This comes from X11R5.
+#
+# Calling this script install-sh is preferred over install.sh, to prevent
+# `make' implicit rules from creating a file called install from it
+# when there is no Makefile.
+#
+# This script is compatible with the BSD install script, but was written
+# from scratch.
+#
+
+
+# set DOITPROG to echo to test this script
+
+# Don't use :- since 4.3BSD and earlier shells don't like it.
+doit="${DOITPROG-}"
+
+
+# put in absolute paths if you don't have them in your path; or use env. vars.
+
+mvprog="${MVPROG-mv}"
+cpprog="${CPPROG-cp}"
+chmodprog="${CHMODPROG-chmod}"
+chownprog="${CHOWNPROG-chown}"
+chgrpprog="${CHGRPPROG-chgrp}"
+stripprog="${STRIPPROG-strip}"
+rmprog="${RMPROG-rm}"
+mkdirprog="${MKDIRPROG-mkdir}"
+
+transformbasename=""
+transform_arg=""
+instcmd="$mvprog"
+chmodcmd="$chmodprog 0755"
+chowncmd=""
+chgrpcmd=""
+stripcmd=""
+rmcmd="$rmprog -f"
+mvcmd="$mvprog"
+src=""
+dst=""
+dir_arg=""
+
+while [ x"$1" != x ]; do
+    case $1 in
+	-c) instcmd="$cpprog"
+	    shift
+	    continue;;
+
+	-d) dir_arg=true
+	    shift
+	    continue;;
+
+	-m) chmodcmd="$chmodprog $2"
+	    shift
+	    shift
+	    continue;;
+
+	-o) chowncmd="$chownprog $2"
+	    shift
+	    shift
+	    continue;;
+
+	-g) chgrpcmd="$chgrpprog $2"
+	    shift
+	    shift
+	    continue;;
+
+	-s) stripcmd="$stripprog"
+	    shift
+	    continue;;
+
+	-t=*) transformarg=`echo $1 | sed 's/-t=//'`
+	    shift
+	    continue;;
+
+	-b=*) transformbasename=`echo $1 | sed 's/-b=//'`
+	    shift
+	    continue;;
+
+	*)  if [ x"$src" = x ]
+	    then
+		src=$1
+	    else
+		# this colon is to work around a 386BSD /bin/sh bug
+		:
+		dst=$1
+	    fi
+	    shift
+	    continue;;
+    esac
+done
+
+if [ x"$src" = x ]
+then
+	echo "install:	no input file specified"
+	exit 1
+else
+	true
+fi
+
+if [ x"$dir_arg" != x ]; then
+	dst=$src
+	src=""
+	
+	if [ -d $dst ]; then
+		instcmd=:
+	else
+		instcmd=mkdir
+	fi
+else
+
+# Waiting for this to be detected by the "$instcmd $src $dsttmp" command
+# might cause directories to be created, which would be especially bad 
+# if $src (and thus $dsttmp) contains '*'.
+
+	if [ -f $src -o -d $src ]
+	then
+		true
+	else
+		echo "install:  $src does not exist"
+		exit 1
+	fi
+	
+	if [ x"$dst" = x ]
+	then
+		echo "install:	no destination specified"
+		exit 1
+	else
+		true
+	fi
+
+# If destination is a directory, append the input filename; if your system
+# does not like double slashes in filenames, you may need to add some logic
+
+	if [ -d $dst ]
+	then
+		dst="$dst"/`basename $src`
+	else
+		true
+	fi
+fi
+
+## this sed command emulates the dirname command
+dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'`
+
+# Make sure that the destination directory exists.
+#  this part is taken from Noah Friedman's mkinstalldirs script
+
+# Skip lots of stat calls in the usual case.
+if [ ! -d "$dstdir" ]; then
+defaultIFS='	
+'
+IFS="${IFS-${defaultIFS}}"
+
+oIFS="${IFS}"
+# Some sh's can't handle IFS=/ for some reason.
+IFS='%'
+set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'`
+IFS="${oIFS}"
+
+pathcomp=''
+
+while [ $# -ne 0 ] ; do
+	pathcomp="${pathcomp}${1}"
+	shift
+
+	if [ ! -d "${pathcomp}" ] ;
+        then
+		$mkdirprog "${pathcomp}"
+	else
+		true
+	fi
+
+	pathcomp="${pathcomp}/"
+done
+fi
+
+if [ x"$dir_arg" != x ]
+then
+	$doit $instcmd $dst &&
+
+	if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi &&
+	if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi &&
+	if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi &&
+	if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi
+else
+
+# If we're going to rename the final executable, determine the name now.
+
+	if [ x"$transformarg" = x ] 
+	then
+		dstfile=`basename $dst`
+	else
+		dstfile=`basename $dst $transformbasename | 
+			sed $transformarg`$transformbasename
+	fi
+
+# don't allow the sed command to completely eliminate the filename
+
+	if [ x"$dstfile" = x ] 
+	then
+		dstfile=`basename $dst`
+	else
+		true
+	fi
+
+# Make a temp file name in the proper directory.
+
+	dsttmp=$dstdir/#inst.$$#
+
+# Move or copy the file name to the temp name
+
+	$doit $instcmd $src $dsttmp &&
+
+	trap "rm -f ${dsttmp}" 0 &&
+
+# and set any options; do chmod last to preserve setuid bits
+
+# If any of these fail, we abort the whole thing.  If we want to
+# ignore errors from any of these, just make sure not to ignore
+# errors from the above "$doit $instcmd $src $dsttmp" command.
+
+	if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi &&
+	if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi &&
+	if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi &&
+	if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi &&
+
+# Now rename the file to the real destination.
+
+	$doit $rmcmd -f $dstdir/$dstfile &&
+	$doit $mvcmd $dsttmp $dstdir/$dstfile 
+
+fi &&
+
+
+exit 0
diff --git a/ps-compiler/compile-gc.scm b/ps-compiler/compile-gc.scm
new file mode 100644
index 0000000..1a57497
--- /dev/null
+++ b/ps-compiler/compile-gc.scm
@@ -0,0 +1,18 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+(config '(load "../scheme/vm/macro-package-defs.scm"))
+(load-package 'vm-architecture)
+(in 'forms '(run (set! *duplicate-lambda-size* 30)))
+(in 'simplify-let '(run (set! *duplicate-lambda-size* 15)))
+(in 'prescheme-compiler
+    '(run (prescheme-compiler
+	   '(allocation heap heap-init images gc)
+	   '("../scheme/vm/interfaces.scm"
+	     "../scheme/vm/ps-package-defs.scm"
+	     "../scheme/vm/package-defs.scm"
+	     "../scheme/vm/gc-package-defs.scm")
+	   's48-heap-init
+	   "../scheme/vm/scheme48heap.c"
+	   '(header "#include \"scheme48vm.h\"")
+	   ;'(copy (heap walk-over-type-in-area))
+	   '(integrate (real-copy-object s48-trace-locations!)))))
diff --git a/ps-compiler/compile-vm-no-gc.scm b/ps-compiler/compile-vm-no-gc.scm
new file mode 100644
index 0000000..7c6fd85
--- /dev/null
+++ b/ps-compiler/compile-vm-no-gc.scm
@@ -0,0 +1,27 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+(config '(load "../scheme/vm/macro-package-defs.scm"))
+(load-package 'vm-architecture)
+(in 'forms '(run (set! *duplicate-lambda-size* 30)))
+(in 'simplify-let '(run (set! *duplicate-lambda-size* 15)))
+(in 'prescheme-compiler
+    '(run (prescheme-compiler
+	   '(vm external-gc-roots)
+	   '("../scheme/vm/interfaces.scm"
+	     "../scheme/vm/ps-package-defs.scm"
+	     "../scheme/vm/package-defs.scm"
+	     "../scheme/vm/no-gc-package-defs.scm")
+	   's48-init
+	   "../scheme/vm/scheme48vm.c"
+	   '(header "#include \"scheme48vm-prelude.h\"")
+	   '(copy (interpreter push-continuation-on-stack))
+	   '(no-copy (interpreter interpret
+				  application-exception
+				  handle-interrupt
+				  uuo)
+		     ;(vm restart)
+		     (interpreter-gc collect-saving-temp
+				     collect-saving-temps)))))
+;	   '(shadow ((interpreter restart)
+;		     (interpreter *val* *code-pointer*)
+;		     (stack *stack* *env*))))))
diff --git a/ps-compiler/compile-vm.scm b/ps-compiler/compile-vm.scm
new file mode 100644
index 0000000..16d9f33
--- /dev/null
+++ b/ps-compiler/compile-vm.scm
@@ -0,0 +1,29 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+(config '(load "../scheme/vm/macro-package-defs.scm"))
+(load-package 'vm-architecture)
+(in 'forms '(run (set! *duplicate-lambda-size* 30)))
+(in 'simplify-let '(run (set! *duplicate-lambda-size* 15)))
+(in 'prescheme-compiler
+    '(run (prescheme-compiler
+	   '(interpreter heap-init)
+	   '("../scheme/vm/interfaces.scm"
+	     "../scheme/vm/ps-package-defs.scm"
+	     "../scheme/vm/package-defs.scm")
+	   'scheme48-init
+	   "../scheme/vm/scheme48vm.c"
+	   '(header "#include \"scheme48vm-prelude.h\"")
+	   '(copy (heap walk-over-type-in-area)
+		  (fixnum-arithmetic quotient-carefully))
+	   '(no-copy (interpreter interpret
+				  application-exception
+				  handle-interrupt
+				  uuo
+				  collect-saving-temp
+				  do-gc))
+	   '(integrate (copy-next do-gc)
+		       (copy-object do-gc))
+	   '(shadow ((interpreter do-gc) (heap *hp*))
+		    ((interpreter restart)
+		     (interpreter *val* *code-pointer*)
+		     (stack *stack* *env*))))))
diff --git a/ps-compiler/doc/node.txt b/ps-compiler/doc/node.txt
new file mode 100644
index 0000000..cc9ce41
--- /dev/null
+++ b/ps-compiler/doc/node.txt
@@ -0,0 +1,340 @@
+
+In the compiler `continuation' means a continuation that is a lambda node.
+Non-lambda continuation arguments, such as the argument to a RETURN, are
+not referred to as continuations (the argument isn't a continuation, it
+is a variable that is bound to a continuation).
+
+
+Every node has the following fields:
+
+  variant     ; one of LITERAL, REFERENCE, LAMBDA, or CALL
+  parent      ; parent node
+  index       ; index of this node in parent, if parent is a call node
+  simplified? ; true if it has already been simplified; if this is #F
+              ; then all of this node's ancestors must also be unsimplified
+  flag        ; useful flag, all users must leave this is #F
+
+
+Literal nodes:
+
+  value     ; the value
+  type      ; the type of the value (important for statically typed languages,
+            ; not so useful for Scheme)
+
+Reference nodes:
+
+  variable  ; the referenced variable; the binder of the variable must be
+            ; an ancestor of the reference node
+
+Call nodes:
+  primop    ; the primitive being called
+  args      ; vector of argument nodes
+  exits     ; the number of arguments that are continuations; the continuation
+            ; arguments come before the non-continuation ones
+  source    ; source info; used for error messages
+
+Primops are either trivial or nontrivial.  Trivial primops only return a value
+and have no side effects.  Calls to trivial primops never have continuation
+arguments and are always arguments to other calls.  Calls to nontrivial primops
+may or may not have continuations and are always the body of a lambda node.
+
+Lambda nodes:
+
+  type      ; one of PROC, CONT, or JUMP (and maybe THROW at some point)
+  name      ; symbol          (for debugging)
+  id        ; unique integer  (for debugging)
+  body      ; the call-node that is the body of the lambda
+  variables ; a list of variable records, with #Fs for ignored positions
+  source    ; source info; used for error messages
+  protocol  ; calling protocol from the source language
+  block     ; for use during code generation
+  env       ; for use when adding explicit environments
+
+PROC's are general procedures.  The first variable of a PROC will be bound
+to the PROC's continuation.
+
+CONT's are continuation arguments to calls.
+
+JUMP's are continuations bound by LET or LETREC, whose calling points are
+known, and which are created and called within a single PROC.
+
+Variables:
+
+  name      ; source code name for variable (used for debugging only)
+  id        ; unique numeric identifier     (used for debugging only)
+  type      ; type of variable's value
+  binder    ; LAMBDA node which binds this variable (or #F if none)
+  refs      ; list of reference nodes n for which (REFERENCE-VARIABLE n)
+            ;  = this variable
+  flag      ; useful slot, used by shapes, COPY-NODE, NODE->VECTOR, etc.
+            ; all users must leave this is #F
+  flags     ; list of various annotations, e.g. IGNORABLE
+  generate  ; for whatever code generation wants
+
+----------------------------------------------------------------
+The node tree has a very regular lexical structure:
+
+  The body of every lambda node is a non-trivial call.
+  The parent of every non-trivial call is a lambda node.
+  Every CONT lambda is a continuation of a non-trivial call.
+  Every JUMP lambda is an argument to either the LET or the LETREC 
+   primops (described below).
+  The lambda node that binds a variable is an ancestor of every reference
+   to that variable.
+  
+If you start from any leaf node and follow the parent pointers up through the
+node tree, you first go through some number, possible zero, of trivial calls
+until a non-trivial call is reached.  From that point on non-trivial calls
+alternate with CONT nodes until a PROC or JUMP lambda is reached.  Going up
+from a PROC lambda is the same as going up from a leaf, while JUMP lambdas
+are always arguments to LET or LETREC, both of which are non-trivial.
+
+A basic block appears as a sequence of non-trivial calls with a single
+continuation apiece.  The block begins with a PROC or JUMP lambda, or
+with a CONT lambda that is an argument to a call with two or more
+continuations, and ends with a call that has either no continuations,
+or two or more.
+
+Basic blocks are grouped into trees.  The root of every tree is either
+a PROC or JUMP lambda, the branch points are calls with two or more
+continuations, and the leaves are jumps or returns.  Within a tree
+the control flow follows the lexical structure of the program from
+parent to child (if we ignore calls to other PROCs).
+
+Every JUMP lambda is called from within only one PROC lambda, so a PROC
+can be considered to consist of a set of trees, the leaves of which either
+return from that PROC or jump to the top of another tree in the set.
+
+----------------------------------------------------------------
+
+Primops:
+
+  id                 ; unique symbol identifying this primop
+  trivial?           ; #t if this primop has does not accept a continuation
+  side-effects       ; one of #F, READ, WRITE, ALLOCATE, or IO
+  simplify-call-proc ; simplify method
+  primop-cost-proc   ; cost of executing this operation
+                     ; (in some undisclosed metric)
+  return-type-proc   ; the type of the value returned (for trivial primops only)
+  proc-data          ; more data for the procedure primops
+  cond-data          ; more data for conditional primops
+  code-data          ; code generation data
+
+`procedure' primops are those that call one of their values.
+`conditional' primops are those that have more than one continuation.
+
+Below is a list of the standard primops.  All but the last two are non-trivial.
+
+For the following the five primops the lambda node being called, jumped to,
+or whatever has been identified by the compiler, and the number of variables
+that the lambda node has matches the number of arguments.
+
+   (CALL <cont> <proc> . <args>)
+   (TAIL-CALL <cont-var> <proc> . <args>)
+   (RETURN <cont-var> . <args>)
+   (JUMP <jump-var> . <args>)
+;  (THROW <throw-var> . <args>)  not yet implemented
+
+These are the same as the above except that the procedure has not been
+identified by the compiler.  There is no UNKNOWN-JUMP because all calls
+to JUMP lambdas must be known.
+
+   (UNKNOWN-CALL <cont> <proc> . <args>)
+   (UNKNOWN-TAIL-CALL <cont> <proc> . <args>)
+   (UNKNOWN-RETURN <cont-var> . <args>)
+
+PROC lambdas are called with either CALL or TAIL-CALL if all of their call
+sites have been identified, or with UNKNOWN-CALL or UNKNOWN-TAIL-CALL if not.
+JUMP lambdas are called using JUMP.
+
+
+LET binds random values, such as lambda nodes or the results of trivial
+calls, to variables.  This primop only exists because of the requirement
+that every call have a primop; all it does is apply <cont> to <args>
+(it is called LET instead of APPLY because LET forms in the source code
+become calls to this primop).
+
+   (LET <cont> . <args>)
+
+
+Recursive binding:
+
+   (LETREC1 <cont>)
+   (LETREC2 <cont> <id-var> <lambda1> <lambda2> ...)
+
+These are always used together, with the body of the continuation to LETREC1
+being a call to LETREC2.  The two calls together look like:
+
+ (LETREC1 (lambda (<id-var> <var1> ... <varN>)
+            (LETREC2 <cont> <id-var> <lambda1> ... <lambdaN>)))
+
+which the CPS pretty-printer prints as:
+
+ (let* (...
+        ((id-var var1 ... varN) (letrec1))
+	(() (letrec2 id-var lambda1 ... lambdaN))
+	...)
+   ...)
+
+The end result is to bind <varI> to <lambdaI>.  The point to the excercise
+is that lambdas occur within the scope of the variables.
+
+
+Undefined effect.  This takes a continuation variable as an argument only
+so that the continuation variable is always reached.
+
+   (UNDEFINED-EFFECT <cont-var> ...)
+
+
+Accessing and mutating the store.
+Cells are used to implement SET! on lexically bound variables.  GLOBAL-SET!
+and GLOBAL-REF are used for module variables that may be set.
+
+   (CELL-SET! <cont> <cell> <value>)
+   (GLOBAL-SET! <cont> <global-var> <value>)
+
+   (CELL-REF <cell>)                 ; trivial
+   (GLOBAL-REF <global-var>)         ; trivial
+
+----------------------------------------------------------------
+Printing out the node tree.
+
+The following procedure:
+
+   (define (fact n)
+     (let loop ((n n) (r 1))
+       (if (< n 2)
+           r
+           (loop (- n 1) (* n r)))))
+
+when converted into nodes is:
+
+(LAMBDAp (c_6 n_1)
+  (letrec1 (LAMBDAc (x_13 loop_2)
+             (letrec2 (LAMBDAc ()
+	                (unknown-tail-call c_6 loop_2 n_1 '1))
+		      x_13
+                      (LAMBDAp (c_8 n_3 r_4)
+                        (test
+                          (LAMBDAc ()
+                            (unknown-return c_8 r_4))
+                          (LAMBDAc ()
+                            (unknown-tail-call c_8 loop_2 (- n_3 '1) (* n_3 r_4)))
+                          (< n_3 '2)))))))
+
+where LAMBDAp is a PROC lambda and LAMBDAc is a CONT lambda.  Lexically bound
+variables are printed as <name>_<id> and constants as '<value>.  This is not
+very readable, and larger procedures are much worse.  The first step in making
+it more comprehensible is to print each lambda node separately with a marker
+to indicate where it appears in the tree.
+
+(LAMBDAp fact_7 (c_6 n_1)
+  (letrec1 1 ^c_14))
+
+  (LAMBDAc c_14 (x_13 loop_2)
+    (letrec2 1 ^c_12 x_13 ^loop_9))
+
+    (LAMBDAc c_12 ()
+      (unknown-tail-call 0 c_6 loop_2 n_1 '1))
+
+    (LAMBDAp loop9 (c_8 n_3 r_4)
+      (test 2 ^g_10 ^g_11 (< n_3 '2)))
+
+      (LAMBDAc g_10 ()
+        (unknown-return 0 c_8 r_4))
+
+      (LAMBDAc g_11 ()
+        (unknown-tail-call 0 c_8 loop_2 (- n_3 '1) (* n_3 r_4)))
+
+The labels used are the names and id's of the lambda nodes, with a ^ in front
+to distinguish them from variables.  The code for each lambda is indented
+slightly more than the lambda in which it actually occurs.  To make the
+distinction between continuation and non-continuation lambdas clearer the
+number of continuation arguments to a call is printed just after the primop
+(for example the first two arguments to TEST are continuations).
+
+The first three calls form a basic block because the first two calls have
+exactly one continuation apiece.  To make this more easily seen these
+calls can be printed using a more condensed notation:
+
+(LAMBDAp fact_7 (c_6 n_1)
+  (LET* (((x_13 loop_2) (letrec1))
+         (()            (letrec2 x_13 ^loop_9)))
+    (unknown-tail-call 0 c_6 loop_2 n_1 '1)))
+
+The continuations are not printed as arguments but instead their variables
+are printed to the left of the call in a parody of Scheme's LET*.  The results
+of the LETREC1 are bound to the variables X_13 and LOOP_2 as would happen with
+the real LET* (if it allowed calls to return multiple values).
+
+Finally, here is the way the code for FACT is actually printed:
+
+7   (P fact_7 (c_6 n_1)
+14    (LET* (((x_13 loop_2)
+                         (letrec1))
+12           (()         (letrec2 x_13 ^loop_9)))
+        (unknown-tail-call 0 c_6 loop_2 n_1 '1)))
+
+9    (P loop_9 (c_8 n_3 r_4)
+       (test 2 ^g_10 ^g_11 (< n_3 '2)))
+
+10    (C g_10 ()
+        (unknown-return 0 c_8 r_4))
+
+11    (C g_11 ()
+        (unknown-tail-call 0 c_8 loop_2 (- n_3 '1) (* n_3 r_4)))
+
+The ID number of every lambda node is printed out at the beginning of the
+line on which the code for the lambda appears.  This is redundant for the
+lambdas that are not printed as part of a LET*.  The word `LAMBDA' is not
+printed.  The (letrec1) call appears on a new line because the printer
+indents the calls in LET* a fixed amount.
+
+The reason for printing the ID numbers is so that the actual nodes can be
+obtained.  Once a lambda has been printed (either by the pretty printer or
+by the regular printer), (NODE-UNHASH <id>) will return it:
+
+  scheme-compiler> (node-unhash 9)
+  '#{Node lambda loop 9}
+  scheme-compiler> ,inspect ##
+  '#{Node lambda loop 9}
+
+   [0: variant] 'lambda
+   [1: parent] '#{Node call letrec2}
+   [2: index] 2
+   [3: simplified?] #t
+   [4: flag] #f
+   [5: stuff-0] '#{Node call test}
+   [6: stuff-1] '(#{Variable n 3} #{Variable r 4})
+   [7: stuff-2] '(#{Name #} (n r) (if # r #))
+   [8: stuff-3] '#{Lambda-data}
+
+----------------------------------------------------------------
+Simplification.
+
+The factorial procedure above is how it looks when originally translated
+into a node tree.  The next step in compilation is to simplify the tree,
+doing constant folding, identifying call points, and so on.  The simplified
+version of FACT is:
+
+7   (P fact_7 (c_6 n_1)
+14    (LET* (((x_13 loop_2)
+                         (letrec1))
+12           (()         (letrec2 x_13 ^loop_9)))
+        (jump 0 loop_2 n_1 '1)))
+
+9    (J loop_9 (n_3 r_4)
+       (test 2 ^g_10 ^g_11 (< n_3 '2)))
+
+10    (C g_10 ()
+        (unknown-return 0 c_6 r_4))
+
+11    (C g_11 ()
+        (jump 0 loop_2 (+ '-1 n_3) (* n_3 r_4)))
+
+The only change is that the loop has been turned into a JUMP lambda.
+
+----------------------------------------------------------------
+Still to describe:
+ protocol determination
+ simplifier moving stuff down, duplicating, later passes move values back up
diff --git a/ps-compiler/doc/todo.txt b/ps-compiler/doc/todo.txt
new file mode 100644
index 0000000..281f1a3
--- /dev/null
+++ b/ps-compiler/doc/todo.txt
@@ -0,0 +1,15 @@
+There is a question about the simplifier for -.
+Also, should (- x x) be checked for?
+
+Join substitute is not quite right: might have (some-test cont1 cont2 V <huge>)
+where V is being tested.  As it stands we'll duplicate <huge>.  Should check
+that it is either small or contains no references to V (in which case we lift
+it with the conts).
+
+Need to come up with good numbers for the maximum size of procs and jumps
+that should be duplicated.
+
+Can join-substitute move stuff above a test?
+
+Pre-Scheme type checker dies on (car '()) if a LET has more variables
+than values.
diff --git a/ps-compiler/front/cps.scm b/ps-compiler/front/cps.scm
new file mode 100644
index 0000000..f5974f4
--- /dev/null
+++ b/ps-compiler/front/cps.scm
@@ -0,0 +1,124 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+; (cps-call <primop> <exits> <first-arg-index> <args> <cps>) ->
+;                   <call-node> + <top-call-node> + <bottom-lambda-node>
+;
+; (cps-sequence <nodes> <cps>) -> <last-node> + <top-call> + <bottom-lambda>
+;
+; (<cps> <node>) -> <value-node> + <top-call-node> + <bottom-lambda-node>
+
+(define (cps-call primop exits first-arg-index args cps)
+  (let ((call (make-call-node primop
+			      (+ (length args) first-arg-index)
+			      exits))
+	(arguments (make-arg-nodes args first-arg-index cps)))
+    (let loop ((args arguments) (first #f) (last #f))
+      (if (null? args)
+	  (values call first last)
+	  (let ((arg (car args)))
+	    (attach call (arg-index arg) (arg-value arg))
+	    (if (and last (arg-first arg))
+		(attach-body last (arg-first arg)))
+	    (loop (cdr args)
+		  (or first (arg-first arg))
+		  (or (arg-last arg) last)))))))
+	    
+; Record to hold information about arguments to calls.
+
+(define-record-type arg :arg
+  (make-arg index rank value first last)
+  arg?
+  (index arg-index)  ; The index of this argument in the call.
+  (rank arg-rank)    ; The estimated cost of executing this node at run time.
+  (value arg-value)  ; What CPS returned for this argument.
+  (first arg-first)
+  (last arg-last))
+
+; Convert the elements of EXP into nodes (if they aren't already) and put
+; them into an ARG record.  Returns the list of ARG records sorted
+; by ARG-RANK.
+
+(define (make-arg-nodes exp start cps)
+  (do ((index start (+ index 1))
+       (args exp (cdr args))
+       (vals '() (cons (receive (value first last)
+			   (cps (car args))
+			 (make-arg index (node-rank first) value first last))
+		       vals)))
+      ((null? args)
+       (sort-list vals
+                  (lambda (v1 v2)
+		    (> (arg-rank v1) (arg-rank v2)))))))
+
+; Complexity analysis used to order argument evaluation.  More complex
+; arguments are to be evaluated first.  This just counts reference nodes.
+; It is almost certainly a waste of time.
+
+(define (node-rank first)
+  (if (not first)
+      0
+      (complexity-analyze-vector (call-args first))))
+
+(define (complexity-analyze node)
+  (cond ((empty? node)
+         0)
+        ((reference-node? node)
+         1)
+        ((lambda-node? node)
+	 (if (not (empty? (lambda-body node)))
+	     (complexity-analyze-vector (call-args (lambda-body node)))
+	     0))
+	((call-node? node)
+	 (complexity-analyze-vector (call-args node)))
+        (else
+         0)))
+
+(define (complexity-analyze-vector vec)
+  (do ((i 0 (+ i 1))
+       (q 0 (+ q (complexity-analyze (vector-ref vec i)))))
+      ((>= i (vector-length vec))
+       q)))
+
+;----------------------------------------------------------------
+; (cps-sequence <nodes> <values-cps>) ->
+;   <last-node> + <top-call> + <bottom-lambda>
+; <values-cps> is the same as the <cps> used above, except that it returns
+; a list of value nodes instead of exactly one.
+
+(define (cps-sequence nodes values-cps)
+  (if (null? nodes)
+      (bug "CPS: empty sequence"))
+  (let loop ((nodes nodes) (first #f) (last #f))
+    (if (null? (cdr nodes))
+	(values (car nodes) first last)
+	(receive (exp-first exp-last)
+	    (cps-sequent (car nodes) values-cps)
+	  (if (and last exp-first)
+	      (attach-body last exp-first))
+	  (loop (cdr nodes) (or first exp-first) (or exp-last last))))))
+
+(define (cps-sequent node values-cps)	  
+  (receive (vals exp-first exp-last)
+      (values-cps node)
+    (receive (calls other)
+	(partition-list call-node? vals)
+      (map erase other)
+      (if (null? calls)
+	  (values exp-first exp-last)
+	  (insert-let calls exp-first exp-last)))))
+
+(define (insert-let calls exp-first exp-last)
+  (let* ((vars (map (lambda (call)
+		      (make-variable 'v (trivial-call-return-type call)))
+		    calls))
+	 (cont (make-lambda-node 'c 'cont vars))
+	 (call (make-call-node (get-primop (enum primop let))
+			       (+ 1 (length calls))
+			       1)))
+    (attach-call-args call (cons cont calls))
+    (cond (exp-first
+	   (attach-body exp-last call)
+	   (values exp-first cont))
+	  (else
+	   (values call cont)))))
+
diff --git a/ps-compiler/front/jump.scm b/ps-compiler/front/jump.scm
new file mode 100644
index 0000000..d584f44
--- /dev/null
+++ b/ps-compiler/front/jump.scm
@@ -0,0 +1,319 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+; Code to turn PROC lambdas into JUMP lambdas.
+
+(define (integrate-jump-procs!)
+  (receive (hits useless)
+      (find-jump-procs (filter proc-lambda? (make-lambda-list)) find-calls)
+    (remove-unused-procedures! useless)
+    (for-each (lambda (p)
+		(procs->jumps (cdr p)
+			      (map bound-to-variable (cdr p))
+			      (car p)))
+	      hits)
+    (not (and (null? hits) (null? useless)))))
+
+; Make a call graph with extra nodes inserted for continuations:
+;
+; If F calls G tail-recursively, add an edge F->G
+; If F calls G ... with continuation K, add a node K and edges F->K, K->G ...
+;
+; Then FIND-JOINS will return a list of the nodes that are passed two or
+; more distinct continuations.  The rest can be merged with their callers.
+;
+; Need a root node, so make one that points to all procs with unknown calls.
+
+(define-record-type node :node
+  (really-make-node proc cont successors join? merged?)
+  node?
+  (proc node-proc)             ; lambda node (or #f for continuation holders)
+  (cont node-cont)             ; lambda node (or #f for procs)
+  (successors node-successors set-node-successors!)
+  (temp node-temp set-node-temp!)
+  (join? node-join? set-node-join?!)
+  (merged? node-merged? set-node-merged?!))
+
+(define (make-node proc cont)
+  (really-make-node proc cont '() #f #f))
+
+(define-record-discloser :node
+  (lambda (node)
+    (list 'node (node-proc node) (node-cont node))))
+
+(define (add-child! parent child)
+  (if (not (memq? child (node-successors parent)))
+      (set-node-successors! parent (cons child (node-successors parent)))))
+
+; We want to find subsets of ALL-PROCS such that all elements of a subset
+; are always called with the same continuation.  (PROC->USES <proc>) returns
+; the references to <proc> that are calls, or #f if there are references that
+; are not calls.
+;
+; We proceed as follows:
+;  1. Partition the procs depending on whether all their calls are known or not.
+;  2. Build a call graph:
+;       Nodes represent either procedures or continuations.  If there is a
+;       tail-recursive call to procedure B in procedure A, then there is an
+;       edge from A to B.  For continuation C such that there is a call in
+;       procedure A to procedure B with that continuation, there are edges
+;       from A to C and from C to B.
+;         In other words, it is a call graph where the edges that represent
+;       non-tail-recursive calls are replaced by two edges, with a node for
+;       the continuation in between.
+;         There is a special root node (representing `outside'), that has
+;       edges to the nodes representing procedures whose call sites have not
+;       been identified.
+;  3. Determine the dominance frontiers in the graph.
+;  4. Find the nodes in the graph that are reachable from more than one
+;     continuation (the joins).
+;  5. Starting from each node that represents a continuation (the joins,
+;     procs whose calls aren't known, and the continuations themselves),
+;     find the set of nodes reachable from that node without going through
+;     some other continuation node.
+
+(define (find-jump-procs all-procs proc->uses)
+  (for-each (lambda (l)
+	      (set-lambda-block! l (make-node l #f)))
+	    all-procs)
+  (receive (known unknown)
+      (partition-list calls-known? all-procs)
+    (let ((root (make-node #f #f))
+	  (conts-cell (list '()))
+	  (known-blocks (map lambda-block known))
+	  (procs-cell (list (map lambda-block unknown))))
+      (note-calls! known conts-cell procs-cell proc->uses)
+      (let ((unknown-blocks (car procs-cell))
+	    (conts (car conts-cell)))
+	(set-node-successors! root unknown-blocks)
+	(graph->ssa-graph! root node-successors node-temp set-node-temp!)
+	(let ((joins (find-joins (append conts unknown-blocks) node-temp)))
+	  (for-each (lambda (n)
+		      (set-node-join?! n #t))
+		    joins)
+	  (let* ((mergable (filter-map find-mergable
+				       (append joins unknown-blocks conts)))
+		 (useless  (filter (lambda (p)
+				     (not (or (node-join? (lambda-block p))
+					      (node-merged? (lambda-block p)))))
+				   known)))
+	    (for-each (lambda (p)
+			(set-lambda-block! p #f))
+		      all-procs)
+	    (values mergable useless)))))))
+
+; Walk KNOWN-PROCS adding edges to the call graph.
+
+(define (note-calls! known-procs conts-cell procs-cell proc->uses)
+  (for-each (lambda (proc)
+	      (for-each (lambda (ref)
+			  (note-call! (lambda-block proc)
+				      ref
+				      conts-cell procs-cell))
+			(proc->uses proc)))
+	    known-procs))
+
+; Add an edge from the node containing REF to PROC-NODE.  Tail calls add an
+; edge directly from the calling node, non-tail calls add an edge from the
+; successor to the calling node that represents the call's continuation.
+
+(define (note-call! proc-node ref conts-cell procs-cell)
+  (let ((caller (get-lambda-block (containing-procedure ref) procs-cell)))
+    (add-child! (if (calls-this-primop? (node-parent ref) 'tail-call)
+		    caller
+		    (get-cont-block caller
+				    (call-arg (node-parent ref) 0)
+				    conts-cell))
+		proc-node)))
+
+; Get the block for lambda-node PROC, making a new one if necessary.
+
+(define (get-lambda-block proc procs-cell)
+  (let ((block (lambda-block proc)))
+    (if (node? block)
+	block
+	(let ((new (make-node proc #f)))
+	  (set-lambda-block! proc new)
+	  (set-car! procs-cell (cons new (car procs-cell)))
+	  new))))
+
+; Get the successor to CALLER containing CONT, making it if necessary.
+
+(define (get-cont-block caller cont conts-cell)
+  (or (any (lambda (node)
+	     (and (node-cont node)
+		  (node-equal? cont (node-cont node))))
+	   (node-successors caller))
+      (let ((cont-node (make-node #f cont)))
+	(set-car! conts-cell (cons cont-node (car conts-cell)))
+	(add-child! caller cont-node)
+	cont-node)))
+
+;----------------
+
+(define (find-mergable node)
+  (let ((mergable (really-find-mergable node)))
+    (if (null? mergable)
+	#f
+	(cons (or (node-cont node)
+		  (car (variable-refs (car (lambda-variables (node-proc node))))))
+	      mergable))))
+
+(define (really-find-mergable node)    
+  (let recur ((nodes (node-successors node)) (res '()))
+    (if (null? nodes)
+	res
+	(recur (cdr nodes)
+	       (let ((node (car nodes)))
+		 (cond ((or (node-join? node)    ; gets two or more continuations
+			    (node-merged? node)  ; already merged
+			    (node-cont node))    ; different continuation
+			res)
+;		       ((node-cont node)          ; not a lambda
+;			(recur (node-successors node) res))
+		       (else
+			(set-node-merged?! node #t)
+			(recur (node-successors node)
+			       (cons (node-proc node) res)))))))))
+
+;=============================================================================;
+; Part 2.  PROCS is a list of procedures that are only called by each other;
+; with no entry point they are useless and can be removed.
+
+(define (remove-unused-procedures! procs)
+  (for-each (lambda (proc)
+	      (let ((var (bound-to-variable proc)))
+		(if (not var)
+		    (bug "known procedure has no variable ~S" proc))
+		(format #t "Removing unused procedure: ~S~%"
+			(variable-name var)) ; would LAMBDA-NAME be better?
+		(mark-changed (node-parent proc))
+		(detach-bound-value var proc)
+		(erase proc)))
+	    procs))
+
+;=============================================================================;
+; Part 3.  Turn JUMP-PROCS from procs to jumps.  CONT is the continuation they
+; all receive, and is also turned into a jump.
+
+; This creates a LETREC to bind all CONT and any of JUMP-PROCS that are
+; passed CONT directly and are bound abouve the LCA of all calls to JUMP-PROCS
+; that use CONT.  Then every jump-proc is changed from a proc lambda to a
+; jump lambda and has its continuation removed.  Returns are replaced with
+; jumps to CONT.  If CONT is not a variable some protocol adjustment may be
+; required.
+
+(define (procs->jumps jump-procs vars cont)
+  (receive (called-vars called-procs lca)
+      (find-cont-uses cont vars jump-procs)
+    (let ((proc (containing-procedure cont))
+	  (lca (if (call-node? lca) lca (node-parent lca)))
+	  (cvar (if (lambda-node? cont)
+		    (make-variable 'w (node-type cont))
+		    #f)))
+      (receive (called-vars called-procs)
+	  (bound-above? lca called-vars called-procs)
+	(for-each detach-bound-value called-vars called-procs)
+	(cond ((lambda-node? cont)
+	       (determine-continuation-protocol cont jump-procs)
+	       (move cont (lambda (ignore) (make-literal-node '#f '#f)))
+	       (put-in-letrec (cons cvar called-vars)
+			      (cons cont called-procs)
+			      lca)
+	       (change-lambda-type cont 'jump))
+	      (else
+	       (put-in-letrec called-vars called-procs lca))))
+      (for-each proc-calls->jumps jump-procs)
+      (for-each (lambda (p)
+		  (let* ((v (car (lambda-variables p)))
+			 (refs (variable-refs v)))
+		    (set-variable-refs! v '())
+		    (for-each (lambda (r)
+				(if (lambda-node? cont)
+				    (return->jump (node-parent r) cvar cont)
+				    (replace r (make-reference-node
+						(car (lambda-variables proc))))))
+			      refs)
+		    (remove-variable p v)))
+		jump-procs)
+      (values))))
+
+; Returns those of VALS and VARS where there is a call to the variable that
+; passes CONT as a continuation, or where the variable is not bound.  The
+; third values returned is the least-common-ancestor of all calls to VARS
+; that use CONT.
+
+(define (find-cont-uses cont vars vals)
+  (let loop ((vars vars) (vals vals) (r-vars '()) (r-vals '()) (uses '()))
+    (if (null? vars)
+	(values r-vars r-vals (least-common-ancestor uses))
+	(let ref-loop ((refs (variable-refs (car vars))) (my-uses uses))
+	  (cond ((not (null? refs))
+		 (ref-loop (cdr refs)
+			   (if (node-equal? cont
+					    (call-arg (node-parent (car refs)) 0))
+			       (cons (car refs) my-uses)
+			       my-uses)))
+		((and (variable-binder (car vars))
+		      (eq? my-uses uses))
+		 (loop (cdr vars) (cdr vals) r-vars r-vals uses))
+		(else
+		 (loop (cdr vars) (cdr vals)
+		       (cons (car vars) r-vars)
+		       (cons (car vals) r-vals)
+		       my-uses)))))))
+
+; Return the list of VARS and VALS where the variable is either global
+; or bound above CALL.
+
+(define (bound-above? call vars vals)
+  (set-node-flag! call #t)
+  (let loop ((vars vars) (vals vals) (r-vars '()) (r-vals '()))
+    (cond ((null? vars)
+	   (set-node-flag! call #f)
+	   (values r-vars r-vals))
+	  ((and (variable-binder (car vars))
+		(marked-ancestor (variable-binder (car vars))))
+	   (loop (cdr vars) (cdr vals) r-vars r-vals))
+	  (else
+	   (loop (cdr vars) (cdr vals)
+		 (cons (car vars) r-vars)
+		 (cons (car vals) r-vals))))))
+
+(define (detach-bound-value var node)
+  (if (variable-binder var)
+      (let ((binder (variable-binder var))
+	    (parent (node-parent node))
+	    (index (node-index node)))
+	(set-lambda-variables! binder (delq! var (lambda-variables binder)))
+	(detach node)
+	(remove-call-arg parent index))))
+  
+; Turn all calls to PROC into jumps.
+
+(define (proc-calls->jumps proc)
+  (for-each (lambda (n)
+	      (call->jump (node-parent n)))
+	    (find-calls proc))
+  (change-lambda-type proc 'jump))
+
+; Change a call to a jump by changing the primop and removing the continuation.
+
+(define (call->jump call)
+  (case (primop-id (call-primop call))
+    ((call tail-call)
+     (set-call-primop! call (get-primop (enum primop jump)))
+     (remove-call-arg call 0))
+    (else
+     (bug "odd call primop ~S" (call-primop call)))))
+
+; Change a return to a jump.  VAR is a variable bound to JUMP, the lambda
+; being jumped to.
+
+(define (return->jump call var jump)
+  (case (primop-id (call-primop call))
+    ((return)
+     (set-call-primop! call (get-primop (enum primop jump)))
+     (replace (call-arg call 0) (make-reference-node var)))
+    (else
+     (bug "odd return primop ~S" (call-primop call)))))
diff --git a/ps-compiler/front/special.scm b/ps-compiler/front/special.scm
new file mode 100644
index 0000000..783517f
--- /dev/null
+++ b/ps-compiler/front/special.scm
@@ -0,0 +1,224 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+; This file is obsolete and no longer used.
+
+;----------------------------------------------------------------------------
+;                           SPECIAL FORMS
+;
+;              QUOTE CALL RETURN BLOCK LAMBDA LETREC
+;               + LET for reasons of type-checking
+;
+;----------------------------------------------------------------------------
+
+(define-record-type quote-exp :quote-exp
+  (make-quote-exp value type)
+  quote-exp?
+  (value quote-exp-value)
+  (type quote-exp-type set-quote-exp-type!))
+
+(define-record-type call-exp :call-exp
+  (make-call-exp! proc exits type args source)
+  call-exp?
+  (proc call-exp-proc)
+  (exits call-exp-exits)
+  (type call-exp-type set-call-exp-type!)
+  (args call-exp-args)
+  (source call-exp-source))
+
+(define-record-type let-exp :let-exp
+  (make-let-exp vars vals body source)
+  let-exp?
+  (vars let-exp-vars)
+  (vals let-exp-vals)
+  (body let-exp-body set-let-exp-body!)
+  (source let-exp-source))
+
+(define-record-type return-exp :return-exp
+  (make-return-exp protocol type args)
+  return-exp?
+  (protocol return-exp-protocol)
+  (type return-exp-type)
+  (args return-exp-args))
+
+(define-record-type block-exp :block-exp
+  (make-block-exp exps)
+  block-exp?
+  (exps block-exp-exps))
+
+(define-record-type lambda-exp :lambda-exp
+  (make-lambda-exp id return-type protocol vars body source)
+  lambda-exp?
+  (id lambda-exp-id)
+  (return-type lambda-exp-return-type set-lambda-exp-return-type!)
+  (protocol lambda-exp-protocol)
+  (vars lambda-exp-vars)
+  (body lambda-exp-body set-lambda-exp-body!)
+  (source lambda-exp-source))
+
+(define (make-continuation-exp vars body)
+  (make-lambda-exp #f #f #f vars body #f))
+
+(define-record-type letrec-exp :letrec-exp
+  (make-letrec-exp vars vals body source)
+  letrec-exp?
+  (vars letrec-exp-vars)
+  (vals letrec-exp-vals)
+  (body letrec-exp-body set-letrec-exp-body!)
+  (source letrec-exp-source))
+
+(define-record-type external-value :external-value
+  (make-external-value type)
+  external-value?
+  (type external-value-type set-external-value-type!))
+
+; Creating nodes and CPS converting calls and blocks.
+;-------------------------------------------------------------------------------
+; (CPS expression) => value + first-call + last-lambda
+;  = the value of the expression
+;    + the first of any calls that must be executed to get the value
+;    + the continuation lambda of the last of the necessary calls
+; The first call and the last lambda will be #F if the value is trivial.
+;
+; (TAIL-CPS expression continuation-variable) => call
+;  = the first call to execute to return the value of the expression to
+;    the continuation variable
+
+(define (cps exp)
+  (let ((value (cps-value exp)))
+    (if value
+	(values value #f #f)
+	(generic-cps exp #f))))
+
+(define (tail-cps exp cont-var)
+  (receive (value type)
+      (cps-value+type exp)
+    (if value
+	(make-value-return cont-var value type)
+	(generic-cps exp cont-var))))
+
+(define (cps-value exp)
+  (receive (value type)
+      (cps-value+type exp)
+    value))
+
+(define (cps-value+type exp)
+  (cond ((variable? exp)
+	 (values (make-reference-node exp) (variable-type exp)))
+	((quote-exp? exp)
+	 (values (make-literal-node (quote-exp-value exp)
+				    (quote-exp-type exp))
+		 (quote-exp-type exp)))
+	((lambda-exp? exp)
+	 (let ((node (lambda-exp->node exp)))
+	   (values node (lambda-node-type node))))
+	(else
+	 (values #f #f))))
+
+(define (generic-cps exp cont-var)
+  (cond ((block-exp? exp)
+	 (make-block (block-exp-exps exp) cont-var))
+	((return-exp? exp)
+	 (make-return-call exp cont-var))
+	((call-exp? exp)
+	 (make-primop-call exp cont-var))
+	((let-exp? exp)
+	 (make-lambda-call exp cont-var))
+	((letrec-exp? exp)
+	 (letrec-exp->node exp cont-var))
+        (else
+         (bug "unknown syntax~% ~S" exp))))
+
+(define (lambda-exp->node exp)
+  (let* ((cvar (make-variable 'c (lambda-exp-return-type exp)))
+         (node (make-lambda-node (lambda-exp-id exp)
+				 'proc
+				 (cons cvar (copy-list (lambda-exp-vars exp))))))
+    (set-lambda-protocol! node (lambda-exp-protocol exp))
+    (set-lambda-source! node (lambda-exp-source exp))
+    (attach-body node (tail-cps (lambda-exp-body exp) cvar))
+    node))
+
+(define (letrec-exp->node exp cont-var)
+  (let ((vals (map cps-value (letrec-exp-vals exp)))
+	(vars (letrec-exp-vars exp))
+	(cont (make-lambda-node 'c 'cont '())))
+    (let-nodes ((top (letrec1 1 l1))
+		(l1 ((x #f) . vars) call2)
+		(call2 (letrec2 1 cont (* x) . vals)))
+      (set-call-source! top (letrec-exp-source exp))
+      (happens-after top cont (letrec-exp-body exp) cont-var))))
+
+; (CATCH id . body)
+; (THROW primop rep id . args)
+
+(define (make-undefined-value)
+  (make-quote-exp the-undefined-value #f))
+
+(define (exp->s-exp exp)
+  (cond ((variable? exp)
+	 (format #f "~S_~S" (variable-name exp) (variable-id exp)))
+	((quote-exp? exp)
+	 (list 'quote (quote-exp-value exp)))
+	((block-exp? exp)
+	 (cons 'begin (map exp->s-exp (block-exp-exps exp))))
+	((return-exp? exp)
+	 (cons 'return (map exp->s-exp (return-exp-args exp))))
+	((call-exp? exp)
+	 `(,(primop-id (call-exp-proc exp))
+	   ,(call-exp-exits exp)
+	   . ,(map exp->s-exp (call-exp-args exp))))
+	((let-exp? exp)
+	 `(let ,(map list
+		     (map exp->s-exp (let-exp-vars exp))
+		     (map exp->s-exp (let-exp-vals exp)))
+	    ,(exp->s-exp (let-exp-body exp))))
+	((lambda-exp? exp)
+	 `(lambda ,(map exp->s-exp (lambda-exp-vars exp))
+	    ,(exp->s-exp (lambda-exp-body exp))))
+	((letrec-exp? exp)
+	 `(letrec ,(map list
+			(map exp->s-exp (letrec-exp-vars exp))
+			(map exp->s-exp (letrec-exp-vals exp)))
+	    ,(exp->s-exp (letrec-exp-body exp))))
+        (else
+         (error '"unknown syntax~% ~S" exp))))
+
+(define (exp-source exp)
+  (cond ((call-exp? exp)
+	 (call-exp-source exp))
+	((let-exp? exp)
+	 (let-exp-source exp))
+	((letrec-exp? exp)
+	 (letrec-exp-source exp))
+	((lambda-exp? exp)
+	 (lambda-exp-source exp))
+	(else
+	 #f)))
+
+(define (find-some-source top-exp exp)
+  (or (exp-source exp)
+      (call-with-current-continuation
+	(lambda (exit)
+	  (let recur ((at top-exp))
+	    (let ((hit? (cond ((eq? at exp)
+			       #t)
+			      ((call-exp? at)
+			       (or (recur (call-exp-proc at))
+				   (any recur (call-exp-args at))))
+			      ((let-exp? at)
+			       (or (recur (let-exp-body at))
+				   (any recur (let-exp-vals at))))
+			      ((letrec-exp? at)
+			       (or (recur (letrec-exp-body at))
+				   (any recur (letrec-exp-vals at))))
+			      ((return-exp? at)
+			       (any recur (return-exp-args at)))
+			      ((lambda-exp? at)
+			       (recur (lambda-exp-body at)))
+			      ((block-exp? at)
+			       (any recur (block-exp-exps at)))
+			      (else #f))))
+	      (if (and hit? (exp-source at))
+		  (exit (exp-source at)))
+	      hit?))))))
+  
\ No newline at end of file
diff --git a/ps-compiler/front/top.scm b/ps-compiler/front/top.scm
new file mode 100644
index 0000000..5230961
--- /dev/null
+++ b/ps-compiler/front/top.scm
@@ -0,0 +1,91 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+; Debugging aids
+
+(define *bad-ids*     '())
+(define *all-procs?*  #f)
+(define *checkpoints* '())
+
+(define all-checkpoints
+  '(node-made
+    simplify1
+    protocols
+    simplify2
+    node->vector
+    pre-simplify-proc
+    envs-added
+    ))
+
+(define (debug-breakpoint loc id data)
+  (if (and (memq? loc *checkpoints*)
+           (or (not id)
+               *all-procs?*
+               (memq? id *bad-ids*)))
+      (breakpoint "~S at ~S is ~S" id loc data)))
+
+(define (add-checks . locs)
+  (receive (okay wrong)
+           (partition-list (lambda (l) (memq? l all-checkpoints))
+                           locs)
+    (set! *checkpoints* (union okay *checkpoints*))
+    (for-each (lambda (l)
+		(format #t '"~&~S is not a checkpoint~%" l))
+	      wrong)
+    *checkpoints*))
+
+(define (clear-checks . locs)
+  (set! *checkpoints*
+	(if (null? locs)
+	    '()
+	    (set-difference *checkpoints* locs))))
+
+(define (add-procs . locs)
+  (if (null? locs)
+      (set! *all-procs?* #t)
+      (set! *bad-ids* (union locs *bad-ids*))))
+
+(define (clear-procs . locs)
+  (cond ((null? locs)
+         (set! *all-procs?* #f)
+         (set! *bad-ids* '()))
+        (else
+         (set! *bad-ids*
+	       (if (null? locs)
+		   '()
+		   (set-difference *bad-ids* locs))))))
+
+(define add-check   add-checks)
+(define clear-check clear-checks)
+(define add-proc    add-procs)
+(define clear-proc  clear-procs)
+
+;------------------------------------------------------------------------------
+
+(define *remove-cells?* #f)
+(define *flow-values?*  #f)
+
+(define (simplify-all node id)
+  (debug-breakpoint 'node-made id node)
+  (simplify-node node)
+  (debug-breakpoint 'simplify1 id node)
+  (determine-protocols)
+  (debug-breakpoint 'protocols id node)
+  (if (integrate-jump-procs!)
+      (simplify-node node))
+  (cond (*remove-cells?*
+         (remove-cells-from-tree node (make-lambda-list))
+         (simplify-node node)))
+  (cond (*flow-values?*
+         (flow-values node (make-lambda-list))
+         (simplify-node node)))
+  (debug-breakpoint 'simplify2 id node)
+  (values))
+
+(define (determine-protocols)
+  (walk-lambdas (lambda (l)
+		  (cond ((and (eq? 'proc (lambda-type l))
+			      (node? (node-parent l))
+			      (find-calls l))
+			 => (lambda (calls)
+			      (determine-lambda-protocol l calls)))))))
diff --git a/ps-compiler/interfaces.scm b/ps-compiler/interfaces.scm
new file mode 100644
index 0000000..48be74d
--- /dev/null
+++ b/ps-compiler/interfaces.scm
@@ -0,0 +1,258 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+(define-interface utilities-interface
+  (export bug
+          user-error
+          user-warning
+          true false
+          or-map
+          remove-similar-elts
+          select-from-table
+          table->list table->entry-list
+          table-push table-pop
+          merge-lists
+          vector-every?
+          make-ignorable
+          sub-vector->list
+          flag-assq
+
+          enforce
+          writec
+          mem?
+          walk-vector
+          vector-replace
+          copy-list
+          copy-vector
+          symbol-hash
+          string-hash
+          char->ascii
+          object-hash
+          union intersection set-difference
+
+          make-xvector xvector-length xvector-ref xvector-set! xvector->vector
+
+          (define-subrecord :syntax)
+          ;(define-simple-record-type :syntax)
+          (define-local-syntax :syntax)
+          ))
+
+(define-interface primop-interface
+  (export primop? make-primop make-proc-primop make-conditional-primop
+          all-primops get-primop
+
+          primop-id primop-trivial? primop-side-effects
+          primop-cost
+          simplify-call
+          primop-procedure? primop-call-index
+          primop-conditional?
+          expand-to-conditional
+          simplify-conditional?
+          primop-code-data set-primop-code-data!
+	  trivial-call-return-type
+
+	  (primop :syntax)
+          ))
+
+(define-interface variable-interface
+  (export variable? make-variable
+          global-variable? make-global-variable
+          variable-name set-variable-name!
+          variable-id
+          variable-type   set-variable-type!
+          variable-binder set-variable-binder!
+          variable-refs   set-variable-refs!
+          variable-flag   set-variable-flag!
+          variable-flags  set-variable-flags!
+	  variable-generate set-variable-generate!
+          erase-variable
+          variable-index copy-variable used? unused?
+          variable-known-value
+	  add-variable-known-value!
+	  remove-variable-known-value!
+          variable-simplifier
+	  add-variable-simplifier!
+	  remove-variable-simplifier!
+	  note-known-global-lambda!
+          ))
+
+(define-interface node-interface
+  (compound-interface
+   primop-interface
+   variable-interface
+   (export reset-node-id node-hash node-unhash
+
+           node? node-variant
+           node-parent set-node-parent!
+           node-index set-node-index!
+           node-simplified? set-node-simplified?!
+           node-flag set-node-flag!
+
+           empty empty? proclaim-empty
+
+           erase
+
+           detach detach-body
+           attach attach-body
+           move move-body
+           insert-body
+           replace replace-body
+
+           mark-changed
+
+           leaf-node?
+          
+           literal-node? make-literal-node
+           literal-value set-literal-value!
+           literal-type  set-literal-type!
+           copy-literal-node
+
+           reference-node? make-reference-node
+           reference-variable set-reference-variable!
+
+           call-node? make-call-node
+           call-primop set-call-primop!
+           call-args set-call-args!
+           call-exits set-call-exits!
+           call-source set-call-source!
+           call-arg call-arg-count
+
+           lambda-node? make-lambda-node
+           lambda-body set-lambda-body!
+           lambda-variables set-lambda-variables!
+           lambda-name set-lambda-name!
+           lambda-id
+           lambda-type
+           lambda-block set-lambda-block!
+	   lambda-env set-lambda-env!
+           lambda-protocol set-lambda-protocol!
+           lambda-source set-lambda-source!
+           lambda-variable-count
+           calls-known? set-calls-known?!
+	   proc-lambda?
+
+           initialize-lambdas add-lambda add-lambdas
+           change-lambda-type
+           walk-lambdas make-lambda-list
+          
+           loc/owner loc/type loc/rep
+           set/owner set/type set/rep set/value
+
+           node-base containing-procedure
+           trivial? nontrivial?
+           nontrivial-ancestor
+           calls-this-primop?
+           bound-to-variable
+           walk-refs-safely
+           small-node?
+           side-effects?
+           called-node? called-node
+           called-lambda
+           get-lambda-value
+           ;set-reference?
+
+           attach-call-args remove-call-args replace-call-args
+           remove-null-arguments
+           shorten-call-args insert-call-arg remove-call-arg
+           append-call-arg
+
+           remove-body
+
+	   put-in-letrec
+
+           remove-lambda-variable remove-variable remove-unused-variables
+
+           substitute substitute-vars-in-node-tree
+           replace-call-with-value
+
+           copy-node-tree
+
+           mark-ancestors marked-ancestor? unmarked-ancestor?
+           node-ancestor? marked-ancestor least-common-ancestor
+           proc-ancestor
+
+           hoistable-node?
+
+           find-scoping
+
+           (let-nodes :syntax)
+
+           node-equal?
+
+           no-free-references?
+
+	   find-calls
+
+	   node-type
+
+           the-undefined-value
+           undefined-value?
+           undefined-value-node?
+           make-undefined-literal
+           )))
+
+(define-interface simplify-internal-interface
+  (export simplify-node
+          default-simplifier
+	  simplify-arg
+          simplify-args
+          simplify-lambda-body
+	  simplify-known-lambda
+          
+          (pattern-simplifier :syntax)
+
+          simplify-allocation
+          simplify-known-call
+          simplify-known-tail-call
+          simplify-unknown-call
+          simplify-return
+          simplify-jump
+          ; simplify-undefined-value
+          simplify-test expand-test simplify-test?
+          ))
+
+(define-interface front-debug-interface
+  (export debug-breakpoint
+          add-checks add-check clear-checks clear-check
+          add-procs add-proc clear-procs clear-proc))
+
+(define-interface front-interface
+  (export simplify-all
+          integrate-jump-procs!  ; for debugging
+          ))
+
+(define-interface annotated-read-interface
+  (export read-and-annotate
+          pair-annotation
+          annotated-cons
+          annotation?
+          annotation-file
+          annotation-form
+          annotation-row
+          annotation-column
+          ))
+
+(define-interface compiler-byte-vector-interface
+  (export make-byte-vector byte-vector? byte-vector-length
+          byte-vector-ref  byte-vector-word-ref  byte-vector-half-word-ref
+          byte-vector-set! byte-vector-word-set! byte-vector-half-word-set!
+          byte-vector-endianess set-byte-vector-endianess!
+          ))
+
+(define-interface parameter-interface
+  (export lookup-primop
+	  lookup-imported-variable
+          
+          type/unknown
+	  type-eq?
+
+          lambda-node-type
+
+          true-value
+          false-value
+
+	  determine-lambda-protocol
+	  determine-continuation-protocol
+          ))
+
+
diff --git a/ps-compiler/load-ps-compiler.scm b/ps-compiler/load-ps-compiler.scm
new file mode 100644
index 0000000..cb6703e
--- /dev/null
+++ b/ps-compiler/load-ps-compiler.scm
@@ -0,0 +1,40 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+; -*- Mode: Scheme; -*-
+
+; To load the Pre-Scheme compiler into Scheme 48:
+;   ,exec ,load load-ps-compiler.scm
+; It needs a larger than default sized heap.  4000000 is big enough to
+; load the pre-scheme compiler but not big enough to compile the VM,
+; 12000000 is enough to compile the VM.
+;
+; compile-vm.exec is an exec script to compile the Scheme 48 virtual machine.
+;
+; This requires that Pre-Scheme already be loaded.
+
+(user '(run (let ((minor-number (call-with-input-file
+				    "minor-version-number"
+				  (lambda (in)
+				    (read in)))))
+	      (newline)
+	      (newline)
+	      (display "Pre-Scheme compiler version 0.")
+	      (display minor-number)
+	      (newline)
+	      (display "Copyright (c) 1994-1999 by Richard Kelsey.")
+	      (newline)
+	      (display "Please report bugs to pre-scheme@martigny.ai.mit.edu.")
+	      (newline)
+	      (newline))))
+
+
+(config)
+(structure 'reflective-tower-maker
+           '(export-reflective-tower-maker))
+(load "interfaces.scm")
+(load "package-defs.scm")
+(load "prescheme/interfaces.scm")
+(load "prescheme/package-defs.scm")
+(load-package 'let-nodes)       ; used in FOR-SYNTAX
+(load-package 'simp-patterns)   ; used in FOR-SYNTAX
+(load-package 'prescheme-compiler)
diff --git a/ps-compiler/load-scheme.scm b/ps-compiler/load-scheme.scm
new file mode 100644
index 0000000..a11b9ff
--- /dev/null
+++ b/ps-compiler/load-scheme.scm
@@ -0,0 +1,11 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+; Load the Scheme front-end
+
+(config)
+(load "interfaces.scm")
+(load "package-defs.scm")
+(load "scheme-to-c/package-defs.scm")
+(load-package 'let-nodes)       ; used in FOR-SYNTAX
+(load-package 'simp-patterns)   ; used in FOR-SYNTAX
+(load-package 'scheme-test)
diff --git a/ps-compiler/minor-version-number b/ps-compiler/minor-version-number
new file mode 100644
index 0000000..7ed6ff8
--- /dev/null
+++ b/ps-compiler/minor-version-number
@@ -0,0 +1 @@
+5
diff --git a/ps-compiler/node/arch.scm b/ps-compiler/node/arch.scm
new file mode 100644
index 0000000..9e5e0fa
--- /dev/null
+++ b/ps-compiler/node/arch.scm
@@ -0,0 +1,40 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+; These are all of the primitives that are known to the compiler.
+
+; The enumeration is needed by the expander for LET-NODES so it ends up
+; being loaded into two separate packages.
+
+(define-enumeration primop
+  (
+   ; Nontrivial Primops
+   call              ; see below
+   tail-call
+   return
+   jump
+   throw
+
+   unknown-call
+   unknown-tail-call
+   unknown-return
+
+   dispatch          ; (dispatch <cont1> ... <contN> <exp>)
+   let               ; (let <lambda-node> . <args>)
+   letrec1           ; (letrec1 (lambda (x v1 v2 ...)
+   letrec2           ;            (letrec2 <cont> x <lambda1> <lambda2> ...)))
+
+   cell-set!
+   global-set!
+
+   undefined-effect  ; (undefined-effect . <maybe-args>)
+
+   ; Trivial Primops
+   make-cell
+   cell-ref
+   global-ref
+
+   ; Environment stuff, these are both trivial
+   closure
+   env-ref
+   ))
diff --git a/ps-compiler/node/leftovers.scm b/ps-compiler/node/leftovers.scm
new file mode 100644
index 0000000..e94104e
--- /dev/null
+++ b/ps-compiler/node/leftovers.scm
@@ -0,0 +1,23 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+; Identifying values called by primops
+
+; Is NODE the value being called by a primop?
+                            
+(define (procedure-node? node)
+  (let ((parent (node-parent node)))
+    (and (node? parent)
+	 (let ((primop (call-primop parent)))
+	   (and (primop-procedure? primop)
+		(eq? (primop-call-index primop)
+		     (node-index node)))))))
+
+; Get the node called at CALL.
+
+(define (called-procedure-node call)
+  (cond ((and (primop-procedure? (call-primop call))
+	      (primop-call-index (call-primop call)))
+	 => (lambda (i)
+	      (call-arg call i)))
+	(else '#f)))
diff --git a/ps-compiler/node/let-nodes.scm b/ps-compiler/node/let-nodes.scm
new file mode 100644
index 0000000..bf3aefb
--- /dev/null
+++ b/ps-compiler/node/let-nodes.scm
@@ -0,0 +1,280 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+;   This is a backquote-like macro for building nodes.
+;
+;   One goal is to produce code that is as efficient as possible.
+;
+; (LET-NODES (<spec1> ... <specN>) . <body>)
+;
+; <spec> ::= (<ident> <real-call>) |                            ; call node
+;            (<ident> (<var1> ... <varN>) <call>) |             ; lambda node
+;            (<ident> (<var1> ... <varN> . <last-vars>) <call>) ; lambda node
+;
+; <var>  ::= #f |             Ignored variable position
+;            <ident> |        Evaluate <ident> and copy it, rebinding <ident>
+;            '<ident> |       Evaluate <ident> to get the variable
+;            (<ident> <rep>)  (MAKE-VARIABLE <ident> <rep>)
+;
+; <last-vars> ::= <ident>
+;
+; <call> ::= <ident> | <real-call>
+;
+; <real-call> ::= (<primop-id> <exits> . <arg-list>)
+;
+; <arg-list> ::= (<arg1> ... <argN>) | (<arg1> ... <argN> . <last-args>)
+;
+; <last-args> ::= <ident>
+;
+; <arg>  ::= 'foo        literal node containing the value of foo, no rep
+;            '(foo rep)     "     "       "       "    "   "   " , using rep
+;            (* foo)     reference to foo (which evaluates to a variable)
+;            (! foo)     foo evaluates to a node
+;            foo         short for (! foo) when foo is an atom
+;            #f          put nothing here
+;            (<primop-id> . <args>)   a nested call
+;--------------------------------------
+;
+; Example:
+;
+;  (let-nodes ((c1 (l1 1 cont))
+;              (l1 ((j type/pointer)) (proc 2 l2 l3 . rest))
+;              (l2 () ((jump cont (* j)) '(true-value type/boolean)))
+;              (l3 () ((jump cont (* j)) '(false-value type/boolean))))
+;    (replace-body node c1))
+;
+;  ==>
+;
+;  (LET ((J (CREATE-VARIABLE 'J TYPE/POINTER)))
+;    (LET ((C1 (CREATE-CALL-NODE '2 1))
+;          (C.1225 (CREATE-CALL-NODE (+ '3 (LENGTH REST)) '2))
+;          (L1 (CREATE-LAMBDA-NODE 'C 'CONT (FLIST1 J '())))
+;          (C.1224 (CREATE-CALL-NODE '4 0))
+;          (L2 (CREATE-LAMBDA-NODE 'C 'CONT '()))
+;          (C.1223 (CREATE-CALL-NODE '4 0))
+;          (L3 (CREATE-LAMBDA-NODE 'C 'CONT '())))
+;      (ATTACH 0 C1 L1)
+;      (ATTACH 1 C1 CONT)
+;      (ATTACH 0 C.1225 PROC)
+;      (ATTACH-CALL-ARGS C.1225 (APPEND (LIST L2 L3) REST))
+;      (ATTACH-BODY L1 C.1225)
+;      (ATTACH 0 C.1224 (CREATE-PRIMOP-NODE PRIMOP/JUMP))
+;      (ATTACH-THREE-CALL-ARGS C.1224
+;                              (CREATE-JUMP-MARKER CONT)
+;                              (CREATE-REFERENCE-NODE J)
+;                              (CREATE-LITERAL-NODE TRUE-VALUE TYPE/BOOLEAN))
+;      (ATTACH-BODY L2 C.1224)
+;      (ATTACH 0 C.1223 (CREATE-PRIMOP-NODE PRIMOP/JUMP))
+;      (ATTACH-THREE-CALL-ARGS C.1223
+;                              (CREATE-JUMP-MARKER CONT)
+;                              (CREATE-REFERENCE-NODE J)
+;                              (CREATE-LITERAL-NODE FALSE-VALUE TYPE/BOOLEAN))
+;      (ATTACH-BODY L3 C.1223)
+;      (REPLACE-BODY NODE C1)))
+; 
+
+(define (expand-let-nodes form rename compare)
+  (destructure (((#f specs . body) form))
+    (receive (vars nodes code)
+	(parse-node-specs specs rename compare)
+      `(,(rename 'let) ,vars
+         (,(rename 'let) ,nodes
+	    ,@code
+	    ,@body)))))
+
+(define (test form)
+  (destructure (((#f specs . body) form))
+    (receive (vars nodes code)
+	(parse-node-specs specs identity eq?)
+      `(let ,vars
+	 (let ,nodes
+	    ,@code
+	    ,@body)))))
+
+; Parse the specs, returning a list of variable specs, a list of node specs,
+; and a list of construction forms.  An input spec is either a call or a
+; lambda, each is parsed by an appropriate procedure.
+
+(define (parse-node-specs specs r c)
+  (let loop ((specs (reverse specs)) (vars '()) (nodes '()) (codes '()))
+    (if (null? specs)
+        (values vars nodes codes)
+        (destructure ((((name . spec) . rest) specs))
+          (cond ((null? (cdr spec))
+                 (receive (node code)
+		     (construct-call name (car spec) r c)
+                   (loop rest vars
+                         `((,name ,node) . ,nodes) (append code codes))))
+                ((= 2 (length spec))
+                 (receive (vs node new-spec call)
+		     (construct-lambda (car spec) (cadr spec) r c)
+                   (loop (if new-spec (cons new-spec rest) rest)
+                         (append vs vars)
+                         `((,name ,node) . ,nodes)
+                         (if call 
+                             `((attach-body ,name ,call) . ,codes)
+                             codes))))
+                (else
+                 (error "illegal spec in LET-NODES ~S" (cons name spec))))))))
+
+; The names of the call-arg relation procedures, indexed by the number of
+; arguments handled.
+
+(define call-attach-names
+  '#(#f
+     #f
+     attach-two-call-args
+     attach-three-call-args
+     attach-four-call-args
+     attach-five-call-args))
+
+; Return the node spec and construction forms for a call.  This dispatches
+; on whether the argument list is proper or not.
+;
+; <real-call> ::= (<arg0> <exits> <arg1> ... <argN>) |
+;                 (<arg0> <exits> <arg1> ... <argN> . <last-args>))
+;                 ((JUMP l-node value) <arg1> ... <argN>)
+;                 ((JUMP l-node value) <arg1> ... <argN> . <last-args>)
+
+(define (construct-call name specs r c)
+  (destructure (((proc . args) specs))
+    (really-construct-call name proc (car args) '() (cdr args) r c)))
+
+(define (construct-nested-call specs r c)
+  (destructure (((primop-id . args) specs))
+    (let ((name (r 'call)))
+      (receive (node code)
+	  (really-construct-call name primop-id 0 '() args r c)
+	`(,(r 'let) ((,name ,node)) ,@code ,name)))))
+		    
+(define (really-construct-call name primop-id exits extra args r c)
+  (receive (arg-count arg-code)
+      (parse-call-args name extra args r c)
+    (let ((primop-code (get-primop-code primop-id r)))
+      (values `(,(r 'make-call-node) ,primop-code ,arg-count ,exits)
+	      arg-code))))
+
+(define (get-primop-code id r)
+  (cond ((name->enumerand id primop)
+	 => (lambda (n)
+	      `(,(r 'get-primop) ,n)))
+	(else
+	 `(,(r 'lookup-primop) ',id))))
+
+; NAME     = the call node which gets the arguments
+; EXTRA    = initial, already expanded arguments
+; ARGS     = unexpanded arguments
+; LAST-ARG = an atom whose value is added to the end of the arguments
+; Returns ARG-COUNT-CODE and ARG-CODE
+
+(define (parse-call-args name extra args r c)
+  (receive (args last-arg)
+      (decouple-improper-list args)
+    (let* ((args (append extra (map (lambda (a) (construct-node a r c)) args)))
+	   (count (length args)))
+      (if (not (null? last-arg))
+	  (values `(,(r '+) ,count (,(r 'length) ,last-arg))
+		  `((,(r 'attach-call-args)
+		     ,name
+		     ,(if (null? args)
+			  last-arg
+			  `(,(r 'append) (,(r 'list) . ,args) ,last-arg)))))
+	  (values count
+		  (cond ((= count 0)
+			 '())
+			((and (= count 1) (car args))
+			 `((,(r 'attach) ,name 0 ,(car args))))
+			((and (< count 6)
+			      (every? identity args))
+			 `((,(r (vector-ref call-attach-names count))
+			    ,name
+			    ,@args)))
+			(else
+			 `((,(r 'attach-call-args) ,name (list . ,args))))))))))
+
+; Return proper part of the list and its last-cdr separately.
+
+(define (decouple-improper-list list)
+  (do ((list list (cdr list))
+       (res '() (cons (car list) res)))
+      ((atom? list)
+       (values (reverse! res) list))))
+
+; Dispatch on the type of the SPEC and return the appropriate code.
+;
+; <arg>  ::= 'foo         literal node containing the value of foo, no rep
+;            '(foo rep)   literal node containing the value of foo
+;            (* foo)      reference to foo (which evaluates to a variable)
+;            (! foo)      foo evaluates to a node
+;            name         short for (! name) when foo is an atom
+
+(define (construct-node spec r c)
+  (cond ((atom? spec) spec)
+        (else
+         (destructure (((key data) spec))
+           (case key
+             ((*)     `(,(r 'make-reference-node) ,data))
+             ((quote) (if (pair? data)
+                          `(,(r 'make-literal-node) . ,data)
+                          `(,(r 'make-literal-node) ,data type/unknown)))
+             ((!)     data)
+             (else
+	      (construct-nested-call spec r c)))))))
+
+; Parse a lambda spec.  This returns a list of variable specs, code to
+; construct the lambda node, a spec for the body if necessary, and
+; the code needed to put it all together.
+
+(define (construct-lambda vars call r c)
+  (receive (vars node)
+           (construct-vars vars r c)
+    (cond ((null? call)
+           (values vars node #f #f))
+          ((atom? call)
+           (values vars node #f call))
+          (else
+           (let ((sym (r (generate-symbol 'c))))
+             (values vars node `(,sym ,call) sym))))))
+
+; Returns the code needed to construct the variables and the code to make
+; the lambda node that binds the variables.
+;
+; <var>  ::= #f |             Ignored variable position
+;            <ident> |        Evaluate <ident> and copy it, rebinding <ident>
+;            '<ident> |       Evaluate <ident> to get the variable
+;            (<ident> <rep>)  (MAKE-VARIABLE <ident> <rep>)
+
+(define (construct-vars vars r c)
+  (let loop ((vs vars) (vlist '()) (code '()))
+    (cond ((atom? vs)
+           (let ((vars (if (null? vs)
+			   `(,(r 'list) . ,(reverse! vlist))
+			   `(,(r 'append) (,(r 'list) . ,(reverse! vlist))
+					  ,vs))))
+             (values code `(,(r 'make-lambda-node) 'c 'cont ,vars))))
+          (else
+           (let ((spec (car vs))
+                 (rest (cdr vs)))
+             (cond ((null? spec)
+                    (loop rest (cons #f vlist) code))
+                   ((atom? spec)
+                    (loop rest (cons spec vlist)
+                          `((,spec (,(r 'copy-variable) ,spec)) . ,code)))
+                   ((c (car spec) 'quote)
+                    (loop rest (cons (cadr spec) vlist) code))
+                   (else
+                    (loop rest (cons (car spec) vlist)
+                          `((,(car spec)
+                             (,(r 'make-variable) ',(car spec) ,(cadr spec)))
+                            . ,code)))))))))
+
+;------------------------------------------------------------------------------
+; GENSYM utility
+
+(define *generate-symbol-index* 0)
+
+(define (generate-symbol sym)
+  (let ((i *generate-symbol-index*))
+    (set! *generate-symbol-index* (+ i 1))
+    (concatenate-symbol sym "." i)))
+
diff --git a/ps-compiler/node/node-equal.scm b/ps-compiler/node/node-equal.scm
new file mode 100644
index 0000000..2466d09
--- /dev/null
+++ b/ps-compiler/node/node-equal.scm
@@ -0,0 +1,77 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+; Determining if two nodes are functionally identical.
+
+(define (node-equal? n1 n2)
+  (if (call-node? n1)
+      (and (call-node? n2)
+           (call-node-eq? n1 n2))
+      (value-node-eq? n1 n2)))
+
+; Compare two call nodes.  The arguments to the nodes are compared
+; starting from the back to do leaf nodes first (usually).
+
+(define (call-node-eq? n1 n2)
+  (and (= (call-arg-count n1) (call-arg-count n2))
+       (= (call-exits     n1) (call-exits     n2))
+       (eq? (call-primop n1) (call-primop n2))
+       (let ((v1 (call-args n1))
+             (v2 (call-args n2)))
+         (let loop ((i (- (vector-length v1) '1)))
+           (cond ((< i '0)
+                  #t)
+                 ((node-equal? (vector-ref v1 i) (vector-ref v2 i))
+                  (loop (- i '1)))
+                 (else
+                  #f))))))
+
+; Compare two value nodes.  Reference nodes are the same if they refer to the
+; same variable or if they refer to corresponding variables in the two node
+; trees.  Primop and literal nodes must be identical.  Lambda nodes are compared
+; by their own procedure.
+
+(define (value-node-eq? n1 n2)
+  (cond ((neq? (node-variant n1) (node-variant n2))
+	 #f)
+	((reference-node? n1)
+	 (let ((v1 (reference-variable n1))
+	       (v2 (reference-variable n2)))
+	   (or (eq? v1 v2) (eq? v1 (variable-flag v2)))))
+	((literal-node? n1)
+	 (and (eq? (literal-value n1) (literal-value n2))
+	      (eq? (literal-type  n1) (literal-type  n2))))
+	((lambda-node? n1)
+	 (lambda-node-eq? n1 n2))))
+
+; Lambda nodes are identical if they have identical variable lists and identical
+; bodies.  The variables of N1 are stored in the flag fields of the variables of
+; N2 for the use of VALUE-NODE-EQ?.
+
+(define (lambda-node-eq? n1 n2)
+  (let ((v1 (lambda-variables n1))
+        (v2 (lambda-variables n2)))
+    (let ((ok? (let loop ((v1 v1) (v2 v2))
+                 (cond ((null? v1)
+                        (if (null? v2)
+                            (call-node-eq? (lambda-body n1) (lambda-body n2))
+                            #f))
+                       ((null? v2) #f)
+                       ((variable-eq? (car v1) (car v2))
+                        (loop (cdr v1) (cdr v2)))
+                       (else #f)))))
+      (map (lambda (v) (if v (set-variable-flag! v #f))) v2)
+      ok?)))
+
+(define (variable-eq? v1 v2)
+  (cond ((not v1)
+         (not v2))
+        ((not v2) #f)
+        ((eq? (variable-type v1) (variable-type v2))
+         (set-variable-flag! v2 v1)
+         #t)
+        (else #f)))
+
+
+
+
diff --git a/ps-compiler/node/node-util.scm b/ps-compiler/node/node-util.scm
new file mode 100644
index 0000000..1c85262
--- /dev/null
+++ b/ps-compiler/node/node-util.scm
@@ -0,0 +1,723 @@
+ 
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+; This file contains miscellaneous utilities for accessing and modifying the
+; node tree.
+
+; Get the root of the tree containing node.
+
+(define (node-base node)
+  (do ((p node (node-parent p)))
+      ((not (node? (node-parent p)))
+       p)))
+
+; Find the procedure node that contains NODE.  Go up one parent at a time
+; until a lambda node is found, then go up two at a time, skipping the
+; intervening call nodes.
+
+(define (containing-procedure node)
+  (do ((node (node-parent node) (node-parent node)))
+      ((lambda-node? node)
+       (do ((node node (node-parent (node-parent node))))
+	   ((proc-lambda? node) node)))))
+
+; Trivial calls are those whose parents are call nodes.
+
+(define (trivial? call)
+  (call-node? (node-parent call)))
+
+(define (nontrivial? call)
+  (lambda-node? (node-parent call)))
+
+(define (nontrivial-ancestor call)
+  (let loop ((call call))
+    (if (or (not (node? (node-parent call)))
+	    (nontrivial? call))
+	call
+	(loop (node-parent call)))))
+
+(define (calls-this-primop? call id)
+  (eq? id (primop-id (call-primop call))))
+
+; Return the variable to which a value is bound by LET or LETREC.
+
+(define (bound-to-variable node)
+  (let ((parent (node-parent node)))
+    (case (primop-id (call-primop parent))
+      ((let)
+       (if (n= 0 (node-index node))
+	   (list-ref (lambda-variables (call-arg parent 0))
+		     (- (node-index node) 1))
+	   #f))
+      ((letrec2)
+       (if (< 1 (node-index node))
+	   (list-ref (lambda-variables
+		      (variable-binder
+		       (reference-variable (call-arg parent 1))))
+		     (- (node-index node) 1))
+	   #f))
+      (else #f))))
+
+; Return a list of all the reference to lambda-node L's value that call it.
+; If not all can be identified then #F is returned.
+
+(define (find-calls l)
+  (let ((refs (cond ((bound-to-variable l)
+		     => variable-refs)
+		    ((called-node? l)
+		     (list l))
+		    (else
+		     #f))))
+    (cond ((and refs (every? called-node? refs))
+	   refs)
+	  ((calls-known? l)
+	   (bug "cannot find calls for known lambda ~S" l))
+	  (else #f))))
+
+; Walk (or map) a tree-modifying procedure down a variable's references.
+
+(define (walk-refs-safely proc var)
+  (for-each proc (copy-list (variable-refs var))))
+
+; Return #t if the total primop-cost of NODE is less than SIZE.
+
+(define (small-node? node size)
+  (let label ((call (lambda-body node)))
+    (set! size (- size (primop-cost call)))
+    (if (>= size 0)
+	(walk-vector (lambda (n)
+		       (cond ((lambda-node? n)
+			      (label (lambda-body n)))
+			     ((call-node? n)
+			      (label n))))
+		     (call-args call))))
+  (>= size 0))
+
+; True if executing NODE involves side-effects.
+
+(define (side-effects? node . permissable)
+  (let ((permissable (cons #f permissable)))
+    (let label ((node node))
+      (cond ((not (call-node? node))
+	     #f)
+	    ((or (n= 0 (call-exits node))
+		 (not (memq (primop-side-effects (call-primop node))
+			    permissable)))
+	     #t)
+	    (else
+	     (let loop ((i (- (call-arg-count node) 1)))
+	       (cond ((< i 0) #f)
+		     ((label (call-arg node i)) #t)
+		     (else (loop (- i 1))))))))))
+
+; A conservative check - is there only one SET-CONTENTS call for the owner and
+; are all calls between CALL and the LETREC call that binds the owner calls to
+; SET-CONTENTS?
+
+;(define (single-letrec-set? call)
+;  (let ((owner (call-arg call set/owner)))
+;    (and (reference-node? owner)
+;	 (every? (lambda (ref)
+;		   (or (eq? (node-parent ref) call)
+;		       (not (set-reference? ref))))
+;		 (variable-refs (reference-variable owner))))))
+    
+;(define (set-reference? node)
+;  (and (eq? 'set-contents
+;	    (primop-id (call-primop (node-parent node))))
+;       (= (node-index node) set/owner)))
+
+;-------------------------------------------------------------------------------
+
+(define the-undefined-value (list '*undefined-value*))
+
+(define (undefined-value? x)
+  (eq? x the-undefined-value))
+
+(define (undefined-value-node? x)
+  (and (literal-node? x)
+       (undefined-value? (literal-value x))))
+
+(define (make-undefined-literal)
+  (make-literal-node the-undefined-value #f))
+
+;-------------------------------------------------------------------------------
+; Finding the lambda node called by CALL, JUMP, or RETURN
+
+(define (called-node? node)
+  (and (node? (node-parent node))
+       (eq? node (called-node (node-parent node)))))
+						   
+(define (called-node call)
+  (cond ((and (primop-procedure? (call-primop call))
+	      (primop-call-index (call-primop call)))
+	 => (lambda (i)
+	      (call-arg call i)))
+	(else '#f)))
+
+(define (called-lambda call)
+  (get-lambda-value (call-arg call (primop-call-index (call-primop call)))))
+
+(define (get-lambda-value value)
+  (cond ((lambda-node? value)
+	 value)
+	((reference-node? value)
+	 (get-variable-lambda (reference-variable value)))
+	(else
+	 (error "peculiar procedure in ~S" value))))
+
+(define (get-variable-lambda variable)
+  (if (global-variable? variable)
+      (or (variable-known-lambda variable)
+	  (error "peculiar procedure variable ~S" variable))
+      (let* ((binder (variable-binder variable))
+	     (index (node-index binder))
+	     (call (node-parent binder))
+	     (lose (lambda ()
+		     (error "peculiar procedure variable ~S" variable))))
+	(case (primop-id (call-primop call))
+	  ((let)
+	   (if (= 0 index)
+	       (get-lambda-value (call-arg call (+ 1 (variable-index variable))))
+	       (lose)))
+	  ((letrec1)
+	   (if (= 0 index)
+	       (get-letrec-variable-lambda variable)
+	       (lose)))
+	  ((call)
+	   (if (and (= 1 index)
+		    (= 0 (variable-index variable))) ; var is a continuation var
+	       (get-lambda-value (call-arg call 0))
+	       (lose)))
+	  (else
+	   (lose))))))
+
+; Some of the checking can be removed once I know the LETREC code works.
+
+(define (get-letrec-variable-lambda variable)
+  (let* ((binder (variable-binder variable))
+	 (call (lambda-body binder)))
+    (if (and (eq? 'letrec2 (primop-id (call-primop call)))
+	     (reference-node? (call-arg call 1))
+	     (eq? (car (lambda-variables binder))
+		  (reference-variable (call-arg call 1))))
+	(call-arg call (+ 1 (variable-index variable)))
+	(error "LETREC is incorrectly organized ~S" (node-parent binder)))))
+
+;(define (get-cell-variable-lambda variable)
+;  (let ((ref (first set-reference? (variable-refs variable))))
+;    (if (and ref
+;	     (eq? 'letrec
+;		  (literal-value (call-arg (node-parent ref) set/type))))
+;	(get-lambda-value (call-arg (node-parent ref) set/value))
+;	(error "peculiar lambda cell ~S" variable))))
+  
+;-------------------------------------------------------------------------------
+; Attaching and detaching arguments to calls
+
+; Make ARGS the arguments of call node PARENT.  ARGS may contain #f.
+
+(define (attach-call-args parent args)
+  (let ((len (call-arg-count parent)))
+    (let loop ((args args) (i 0))
+      (cond ((null? args)
+             (if (< i (- len 1))
+                 (bug '"too few arguments added to node ~S" parent))
+             (values))
+            ((>= i len)
+             (bug '"too many arguments added to node ~S" parent))
+            (else
+	     (if (car args)
+		 (attach parent i (car args)))
+	     (loop (cdr args) (+ 1 i)))))))
+
+; Remove all of the arguments of NODE.
+
+(define (remove-call-args node)
+  (let ((len (call-arg-count node)))
+    (do ((i 1 (+ i 1)))
+        ((>= i len))
+      (if (not (empty? (call-arg node i)))
+          (erase (detach (call-arg node i)))))
+    (values)))
+
+; Replace the arguments of call node NODE with NEW-ARGS.
+
+(define (replace-call-args node new-args)
+  (let ((len (length new-args)))
+    (remove-call-args node)
+    (if (n= len (call-arg-count node))
+        (let ((new (make-vector len empty))
+              (old (call-args node)))
+          (set-call-args! node new)))
+    (attach-call-args node new-args)))
+
+; Remove all arguments to CALL that are EMPTY?.  COUNT is the number of
+; non-EMPTY? arguments.
+
+(define (remove-null-arguments call count)
+  (let ((old (call-args call))
+        (new (make-vector count empty)))
+    (let loop ((i 0) (j 0))
+      (cond ((>= j count)
+	     (values))
+            ((not (empty? (vector-ref old i)))
+             (set-node-index! (vector-ref old i) j)
+             (vector-set! new j (vector-ref old i))
+             (loop (+ i 1) (+ j 1)))
+            (else
+             (loop (+ i 1) j))))
+    (set-call-args! call new)
+    (values)))
+
+; Remove all but the first COUNT arguments from CALL.
+
+(define (shorten-call-args call count)
+  (let ((old (call-args call))
+        (new (make-vector count empty)))
+    (vector-replace new old count)
+    (do ((i (+ count 1) (+ i 1)))
+        ((>= i (vector-length old)))
+      (erase (vector-ref old i)))
+    (set-call-args! call new)
+    (values)))
+
+; Insert ARG as the INDEXth argument to CALL.
+
+(define (insert-call-arg call index arg)
+  (let* ((old (call-args call))
+         (len (vector-length old))
+         (new (make-vector (+ 1 len) empty)))
+    (vector-replace new old index)
+    (do ((i index (+ i 1)))
+        ((>= i len))
+      (vector-set! new (+ i 1) (vector-ref old i))
+      (set-node-index! (vector-ref old i) (+ i 1)))
+    (set-call-args! call new)
+    (attach call index arg)
+    (values)))
+
+; Remove the INDEXth argument to CALL.
+
+(define (remove-call-arg call index)
+  (let* ((old (call-args call))
+         (len (- (vector-length old) 1))
+         (new (make-vector len)))
+    (vector-replace new old index)
+    (if (node? (vector-ref old index))
+        (erase (detach (vector-ref old index))))
+    (do ((i index (+ i 1)))
+        ((>= i len))
+      (vector-set! new i (vector-ref old (+ i 1)))
+      (set-node-index! (vector-ref new i) i))
+    (set-call-args! call new)
+    (if (< index (call-exits call))
+        (set-call-exits! call (- (call-exits call) 1)))
+    (values)))
+
+; Add ARG to the end of CALL's arguments.
+
+(define (append-call-arg call arg)
+  (insert-call-arg call (call-arg-count call) arg)) 
+
+; Replace CALL with the body of its continuation.
+
+(define (remove-body call)
+  (if (n= 1 (call-exits call))
+      (bug "removing a call with ~D exits" (call-exits call))
+      (replace-body call (detach-body (lambda-body (call-arg call 0))))))
+
+; Avoiding N-Ary Procedures
+; These are used in the expansion of the LET-NODES macro.
+
+(define (attach-two-call-args node a0 a1)
+  (attach node 0 a0)
+  (attach node 1 a1))
+
+(define (attach-three-call-args node a0 a1 a2)
+  (attach node 0 a0)
+  (attach node 1 a1)
+  (attach node 2 a2))
+
+(define (attach-four-call-args node a0 a1 a2 a3)
+  (attach node 0 a0)
+  (attach node 1 a1)
+  (attach node 2 a2)
+  (attach node 3 a3))
+
+(define (attach-five-call-args node a0 a1 a2 a3 a4)
+  (attach node 0 a0)
+  (attach node 1 a1)
+  (attach node 2 a2)
+  (attach node 3 a3)
+  (attach node 4 a4))
+
+;-------------------------------------------------------------------------------
+; Bind VARS to VALUES using letrec at CALL.  If CALL is already a letrec
+; call, just add to it, otherwise make a new one.
+
+(define (put-in-letrec vars values call)
+  (cond ((eq? 'letrec2 (primop-id (call-primop call)))
+	 (let ((binder (node-parent call)))
+	   (mark-changed call)
+	   (for-each (lambda (var)
+		       (set-variable-binder! var binder))
+		     vars)
+	   (set-lambda-variables! binder
+				  (append (lambda-variables binder) vars))
+	   (for-each (lambda (value)
+		       (append-call-arg call value))
+		     values)))
+	(else
+	 (move-body
+	  call
+	  (lambda (call)
+	    (let-nodes ((c (letrec1 1 l2))
+			(l2 ((x #f) . vars) (letrec2 1 l3 (* x) . values))
+			(l3 () call))
+	      c))))))
+
+;-------------------------------------------------------------------------------
+; Changing lambda-nodes' variable lists
+
+(define (remove-lambda-variable l-node index)
+  (remove-variable l-node (list-ref (lambda-variables l-node) index)))
+
+(define (remove-variable l-node var)
+  (if (used? var)
+      (bug '"cannot remove referenced variable ~s" var))
+  (erase-variable var)
+  (let ((vars (lambda-variables l-node)))
+    (if (eq? (car vars) var)
+        (set-lambda-variables! l-node (cdr vars))
+        (do ((vars vars (cdr vars)))
+            ((eq? (cadr vars) var)
+             (set-cdr! vars (cddr vars)))))))
+
+; Remove all of L-NODES' unused variables.
+
+(define (remove-unused-variables l-node)
+  (set-lambda-variables! l-node
+			 (filter! (lambda (v)
+				    (cond ((used? v)
+					   #t)
+					  (else
+					   (erase-variable v)
+					   #f)))
+				  (lambda-variables l-node))))
+
+;------------------------------------------------------------------------------
+; Substituting Values For Variables
+
+; Substitute VAL for VAR.  If DETACH? is true then VAL should be detached
+; and so can be used instead of a copy for the first substitution.
+;
+; If VAL is a reference to a variable named V, it was probably introduced by
+; the CPS conversion code.  In that case, the variable is renamed with the
+; name of VAR.  This helps considerably when debugging the compiler.
+
+(define (substitute var val detach?)
+  (if (and (reference-node? val)
+           (eq? 'v (variable-name (reference-variable val)))
+	   (not (global-variable? (reference-variable val))))
+      (set-variable-name! (reference-variable val)
+           (variable-name var)))
+  (let ((refs (variable-refs var)))
+    (set-variable-refs! var '())
+    (cond ((not (null? refs))
+           (for-each (lambda (ref)
+		       (replace ref (copy-node-tree val)))
+		     (if detach? (cdr refs) refs))
+           (if detach? (replace (car refs) (detach val))))
+          (detach?
+           (erase (detach val))))))
+
+; Walk the tree NODE replacing references to variables in OLD-VARS with
+; the corresponding variables in NEW-VARS.  Uses VARIABLE-FLAG to mark
+; the variables being replaced.
+
+(define (substitute-vars-in-node-tree node old-vars new-vars)
+  (for-each (lambda (old new)
+	      (set-variable-flag! old new))
+	    old-vars
+	    new-vars)
+  (let tree-walk ((node node))
+    (cond ((lambda-node? node)
+           (walk-vector tree-walk (call-args (lambda-body node))))
+          ((call-node? node)
+           (walk-vector tree-walk (call-args node)))
+          ((and (reference-node? node)
+                (variable-flag (reference-variable node)))
+           => (lambda (new)
+                (replace node (make-reference-node new))))))
+  (for-each (lambda (old) 
+	      (set-variable-flag! old #f))
+	    old-vars))
+
+; Replaces the call node CALL with VALUE.
+; (<proc> <exit> . <args>) => (<exit> <value>)
+
+(define (replace-call-with-value call value)
+  (cond ((n= 1 (call-exits call))
+         (bug '"can only substitute for call with one exit ~s" call))
+        (else
+	 (let ((cont (detach (call-arg call 0))))
+	   (set-call-exits! call 0)
+	   (replace-call-args call (if value (list cont value) (list cont)))
+	   (set-call-primop! call (get-primop (enum primop let)))))))
+
+;------------------------------------------------------------------------------
+; Copying Node Trees
+
+; Copy the node-tree NODE.  This dispatches on the type of NODE.
+; Variables which have been copied have the copy in the node-flag field.
+
+(define (copy-node-tree node)
+  (let ((new (cond ((lambda-node? node)
+		    (copy-lambda node))
+		   ((reference-node? node)
+		    (let ((var (reference-variable node)))
+		      (cond ((and (variable-binder var)
+				  (variable-flag var))
+			     => make-reference-node)
+			    (else
+			     (make-reference-node var)))))
+		   ((call-node? node)
+		    (copy-call node))
+		   ((literal-node? node)
+		    (copy-literal-node node)))))
+    new))
+
+; Copy a lambda node and its variables.  The variables' copies are put in
+; their VARIABLE-FLAG while the lambda's body is being copied.
+
+(define (copy-lambda node)
+  (let* ((vars (map (lambda (var)
+		      (if var
+			  (let ((new (copy-variable var)))
+			    (set-variable-flag! var new)
+			    new)
+			  #f))
+		    (lambda-variables node)))
+         (new-node (make-lambda-node (lambda-name node)
+				     (lambda-type node)
+				     vars)))
+    (attach-body new-node (copy-call (lambda-body node)))
+    (set-lambda-protocol! new-node (lambda-protocol node))
+    (set-lambda-source! new-node (lambda-source node))
+    (for-each (lambda (var)
+		(if var (set-variable-flag! var #f)))
+	      (lambda-variables node))
+    new-node))
+
+(define (copy-call node)
+  (let ((new-node (make-call-node (call-primop node)
+				  (call-arg-count node)
+				  (call-exits node))))
+    (do ((i 0 (+ i 1)))
+        ((>= i (call-arg-count node)))
+      (attach new-node i (copy-node-tree (call-arg node i))))
+    (set-call-source! new-node (call-source node))
+    new-node))
+
+;------------------------------------------------------------------------------
+; Checking the scoping of identifers
+
+; Mark all ancestors of N with FLAG
+
+(define (mark-ancestors n flag)
+  (do ((n n (node-parent n)))
+      ((not (node? n)) (values))
+    (set-node-flag! n flag)))
+
+; Does N have an ancestor with a non-#f flag?
+
+(define (marked-ancestor? n)
+  (do ((n n (node-parent n)))
+      ((or (not (node? n))
+           (node-flag n))
+       (node? n))))
+
+; Does N have an ancestor with a #f flag?
+
+(define (unmarked-ancestor? n)
+  (do ((n n (node-parent n)))
+      ((or (not (node? n))
+           (not (node-flag n)))
+       (node? n))))
+
+; Is ANC? an ancestor of NODE?
+
+(define (node-ancestor? anc? node)
+  (set-node-flag! anc? #t)
+  (let ((okay? (marked-ancestor? node)))
+    (set-node-flag! anc? #f)
+    okay?))
+
+; Find the lowest ancestor of N that has a non-#f flag
+
+(define (marked-ancestor n)
+  (do ((n n (node-parent n)))
+      ((or (not (node? n))
+           (node-flag n))
+       (if (node? n) n #f))))
+
+; Mark the ancestors of START with #f, stopping when END is reached
+
+(define (unmark-ancestors-to start end)
+  (do ((node start (node-parent node)))
+      ((eq? node end))
+    (set-node-flag! node #f)))
+
+; Return the lowest node that is above all NODES
+
+(define (least-common-ancestor nodes)
+  (mark-ancestors (car nodes) #t)
+  (let loop ((nodes (cdr nodes)) (top (car nodes)))
+    (cond ((null? nodes)
+           (mark-ancestors top #f)
+           top)
+          (else
+           (let ((new (marked-ancestor (car nodes))))
+             (unmark-ancestors-to top new)
+             (loop (cdr nodes) new))))))
+
+; Can TO be moved to FROM without taking variables out of scope.
+; This first marks all of the ancestors of FROM, and then unmarks all of the
+; ancestors of TO.  The net result is to mark every node that is above FROM but
+; not above TO.  Then if any reference-node below FROM references a variable
+; with a marked binder, that node, and thus FROM itself, cannot legally be
+; moved to TO.
+
+; This is not currently used anywhere, and it doesn't know about trivial
+; calls.
+
+(define (hoistable-node? from to)
+  (let ((from (if (call-node? from)
+		  (node-parent (nontrivial-ancestor from))
+		  from)))
+    (mark-ancestors (node-parent from) #t)
+    (mark-ancestors to #f)
+    (let ((okay? (let label ((n from))
+                   (cond ((lambda-node? n)
+                          (let* ((vec (call-args (lambda-body n)))
+                                 (c (vector-length vec)))
+                            (let loop ((i 0))
+                              (cond ((>= i c) #t)
+                                    ((label (vector-ref vec i))
+                                     (loop (+ i 1)))
+                                    (else #f)))))
+                         ((reference-node? n)
+                          (let ((b (variable-binder (reference-variable n))))
+                            (or (not b) (not (node-flag b)))))
+                         (else #t)))))
+      (mark-ancestors (node-parent from) #f)
+      okay?)))
+
+; Mark all of the lambda nodes which bind variables referenced below NODE.
+
+(define (mark-binders node)
+  (let label ((n node))
+    (cond ((lambda-node? n)
+           (walk-vector label (call-args (lambda-body n))))
+          ((reference-node? n)
+           (let ((b (variable-binder (reference-variable n))))
+             (if b (set-node-flag! b #f))))))
+  (values))
+
+
+;------------------------------------------------------------------------------
+; For each lambda-node L this sets (PARENT L) to be the enclosing PROC node
+; of L and, if L is a PROC node, sets (KIDS L) to be the lambda nodes it
+; encloses.
+
+(define (find-scoping lambdas parent set-parent! kids set-kids!)
+  (receive (procs others)
+      (partition-list proc-lambda? lambdas)
+    (for-each (lambda (l)
+		(set-parent! l #f)
+		(set-kids!   l '()))
+	      procs)
+    (for-each (lambda (l)
+		(set-parent! l #f))
+	      others)
+    (letrec ((set-lambda-parent!
+	      (lambda (l)
+		(cond ((parent l)
+		       => identity)
+		      ((proc-ancestor l)
+		       => (lambda (p)
+			    (let ((p (if (proc-lambda? p)
+					 p
+					 (set-lambda-parent! p))))
+			      (set-kids! p (cons l (kids p)))
+			      (set-parent! l p)
+			      p)))
+		      (else #f)))))
+      (for-each set-lambda-parent! lambdas))
+    (values procs others)))
+
+(define (proc-ancestor node)
+  (let ((p (node-parent node)))
+    (if (not (node? p))
+        #f
+        (let ((node (do ((p p (node-parent p)))
+			((lambda-node? p)
+			 p))))
+          (do ((node node (node-parent (node-parent node))))
+              ((proc-lambda? node)
+	       node))))))
+
+(define (no-free-references? node)
+  (if (call-node? node)
+      (error "NO-FREE-REFERENCES only works on value nodes: ~S" node))
+  (let label ((node node))
+    (cond ((reference-node? node)
+	   (let ((b (variable-binder (reference-variable node))))
+	     (or (not b)
+		 (node-flag b))))
+	  ((lambda-node? node)
+	   (set-node-flag! node #t)
+	   (let* ((vec (call-args (lambda-body node)))
+		  (res (let loop ((i (- (vector-length vec) 1)))
+			 (cond ((< i 0) #t)
+			       ((not (label (vector-ref vec i))) #f)
+			       (else (loop (- i 1)))))))
+	     (set-node-flag! node #f)
+	     res))
+	  (else
+	   #t))))
+
+(define (node-type node)
+  (cond ((literal-node? node)
+	 (literal-type node))
+	((reference-node? node)
+	 (variable-type (reference-variable node)))
+	((lambda-node? node)
+	 (lambda-node-type node))
+	((and (call-node? node)
+	      (primop-trivial? (call-primop node)))
+	 (trivial-call-return-type node))
+	(else
+	 (error "node ~S does not represent a value" node))))
+
+;----------------------------------------------------------------
+; Debugging utilities
+
+(define (show-simplified node)
+  (let loop ((n node) (r '()))
+    (if (node? n)
+	(loop (node-parent n) (cons (node-simplified? n) r))
+	(reverse r))))
+
+(define (show-flag node)
+  (let loop ((n node) (r '()))
+    (if (node? n)
+        (loop (node-parent n) (cons (node-flag n) r))
+	(reverse r))))
+
+(define (reset-simplified node)
+  (let loop ((n node))
+    (cond ((node? n)
+	   (set-node-simplified?! n #f)
+	   (loop (node-parent n))))))
diff --git a/ps-compiler/node/node.scm b/ps-compiler/node/node.scm
new file mode 100644
index 0000000..0139bc0
--- /dev/null
+++ b/ps-compiler/node/node.scm
@@ -0,0 +1,544 @@
+
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+; This file contains the definitions of the node tree data structure.
+
+;---------------------------------------------------------------------------
+; Records to represent variables.
+
+(define-record-type variable
+  ((name)        ; Source code name for variable (used for debugging only)
+   (id)          ; Unique numeric identifier     (used for debugging only)
+   (type)        ; Type for variable's value
+   )
+  (binder        ; LAMBDA node which binds this variable
+   (refs '())    ; List of leaf nodes n for which (REFERENCE-VARIABLE n) = var.
+   (flag #f)     ; Useful slot, used by shapes, COPY-NODE, NODE->VECTOR, etc.
+                 ; all users must leave this is #F
+   (flags '())   ; For various annotations, e.g. IGNORABLE
+   (generate #f) ; For whatever code generation wants
+   ))
+
+(define-record-discloser type/variable
+  (lambda (var)
+    (node-hash var)
+    (list 'variable (variable-name var) (variable-id var))))
+
+(define (make-variable name type)
+  (variable-maker name (new-id) type))
+
+(define (make-global-variable name type)
+  (let ((var (make-variable name type)))
+    (set-variable-binder! var #f)
+    var))
+
+(define (global-variable? var)
+  (not (variable-binder var)))
+
+; Every variable has a unique numeric identifier that is used for printing.
+
+(define *variable-id* 0)
+
+(define (new-id)
+  (let ((id *variable-id*))
+    (set! *variable-id* (+ 1 *variable-id*))
+    id))
+
+(define (erase-variable var)
+  (cond ((eq? (variable-id var) '<erased>)
+	 (bug "variable ~S already erased" var))
+	(else
+	 (set-variable-id! var '<erased>))))
+
+(define *node-hash-table* #f)
+
+(define (reset-node-id)
+  (set! *variable-id* 0)
+  (set! *node-hash-table* (make-table)))
+
+(define (node-hash var-or-lambda)
+  (let ((id (if (variable? var-or-lambda)
+		(variable-id var-or-lambda)
+		(lambda-id var-or-lambda))))
+    (table-set! *node-hash-table* id var-or-lambda)))
+
+(define (node-unhash n)
+  (table-ref *node-hash-table* n))
+
+; The index of VAR in the variables bound by its binder.
+
+(define (variable-index var)
+  (let ((binder (variable-binder var)))
+    (if (not binder)
+	(bug "VARIABLE-INDEX called on global variable ~S" var)
+	(do ((i 0 (+ i 1))
+	     (vs (lambda-variables binder) (cdr vs)))
+	    ((eq? (car vs) var)
+	     i)))))
+
+; Copy an old variable.
+
+(define (copy-variable old)
+  (let ((var (make-variable (variable-name old) (variable-type old))))
+    (set-variable-flags! var (variable-flags old))
+    var))
+
+; An unused variable is either #F or a variable with no references.
+
+(define (used? var)
+  (and var
+       (not (null? (variable-refs var)))))
+
+(define (unused? var)
+  (not (used? var)))
+
+; known values for top-level variables
+
+(define (flag-accessor flag)
+  (lambda (var)
+    (let ((p (flag-assq flag (variable-flags var))))
+      (if p (cdr p) #f))))
+
+(define (flag-setter flag)
+  (lambda (var value)
+    (set-variable-flags! var
+			 (cons (cons flag value)
+			       (variable-flags var)))))
+
+(define (flag-remover flag)
+  (lambda (var)
+    (set-variable-flags! var (filter (lambda (x)
+				       (or (not (pair? x))
+					   (not (eq? (car x) flag))))
+				     (variable-flags var)))))
+  
+(define variable-known-value (flag-accessor 'known-value))
+(define add-variable-known-value! (flag-setter 'known-value))
+(define remove-variable-known-value! (flag-remover 'known-value))
+
+(define variable-simplifier (flag-accessor 'simplifier))
+(define add-variable-simplifier! (flag-setter 'simplifier))
+(define remove-variable-simplifier! (flag-remover 'simplifier))
+
+(define variable-known-lambda (flag-accessor 'known-lambda))
+(define note-known-global-lambda! (flag-setter 'known-lambda))
+
+;----------------------------------------------------------------------------
+; The main record for the node tree
+
+(define-record-type node
+  ((variant)           ; One of LAMBDA, CALL, REFERENCE, LITERAL
+   )
+  ((parent empty)      ; Parent node
+   (index '<free>)     ; Index of this node in parent
+   (simplified? #f)    ; True if it has already been simplified.
+   (flag #f)           ; Useful flag, all users must leave this is #F
+   stuff-0             ; Variant components - each type of node has a different
+   stuff-1             ; use for these fields
+   stuff-2
+   stuff-3
+   ))
+
+(define-record-discloser type/node
+  (lambda (node)
+    `(node ,(node-variant node)
+	   . ,(case (node-variant node)
+		((lambda)
+		 (node-hash node)
+		 (list (lambda-name node) (lambda-id node)))
+		((call)
+		 (list (primop-id (call-primop node))))
+		((reference)
+		 (let ((var (reference-variable node)))
+		   (list (variable-name var) (variable-id var))))
+		((literal)
+		 (list (literal-value node)))
+		(else
+		 '())))))
+
+(define make-node node-maker)
+
+;--------------------------------------------------------------------------
+; EMPTY is used to mark empty parent and child slots in nodes.
+
+(define empty
+  (list 'empty))
+
+(define (empty? obj) (eq? obj empty))
+
+(define (proclaim-empty probe)
+  (cond ((not (empty? probe))
+         (bug "not empty - ~S" probe))))
+
+;----------------------------------------------------------------------------
+; This walks the tree rooted at NODE and removes all pointers that point into
+; this tree from outside.
+
+(define (erase node)
+  (let label ((node node))
+    (cond ((empty? node)
+           #f)
+          (else
+           (case (node-variant node)
+             ((lambda)
+              (label (lambda-body node)))
+             ((call)
+              (walk-vector label (call-args node))))
+           (really-erase node)))))
+
+; This does the following:
+; Checks that this node has not already been removed from the tree.
+;
+; Reference nodes are removed from the refs list of the variable they reference.
+;
+; For lambda nodes, the variables are erased, non-CONT lambdas are removed from
+; the *LAMBDAS* list (CONT lambdas are never on the list).
+;
+; Literal nodes whose values have reference lists are removed from those
+; reference lists.
+
+(define (really-erase node)
+  (cond ((empty? node)
+         #f)
+        (else
+         (cond ((eq? (node-index node) '<erased>)
+                (bug "node erased twice ~S" node))
+               ((reference-node? node)
+		(let ((var (reference-variable node)))
+		  (set-variable-refs! var
+				      (delq! node (variable-refs var)))))
+               ((lambda-node? node)
+                (for-each (lambda (v)
+			    (if v (erase-variable v)))
+			  (lambda-variables node))
+                (if (neq? (lambda-type node) 'cont)
+                    (delete-lambda node))
+                (set-lambda-variables! node '()))  ; safety
+               ((literal-node? node)
+                (let ((refs (literal-refs node)))
+                  (if refs
+		      (set-literal-reference-list!
+		       refs
+                       (delq! node (literal-reference-list refs)))))))
+;	 (erase-type (node-type node))
+         (set-node-index! node '<erased>))))
+
+;---------------------------------------------------------------------------
+; CONNECTING AND DISCONNECTING NODES
+;
+; There are two versions of each of these routines, one for value nodes
+; (LAMBDA, REFERENCE, or LITERAL), and one for call nodes.
+
+; Detach a node from the tree.
+
+(define (detach node)
+  (vector-set! (call-args (node-parent node))
+	       (node-index node)
+	       empty)
+  (set-node-index! node #f)
+  (set-node-parent! node empty)
+  node)
+
+(define (detach-body node)
+  (set-lambda-body! (node-parent node) empty)
+  (set-node-index! node #f)
+  (set-node-parent! node empty)
+  node)
+
+; Attach a node to the tree.
+
+(define (attach parent index child)
+  (proclaim-empty (node-parent child))
+  (proclaim-empty (vector-ref (call-args parent) index))
+  (vector-set! (call-args parent) index child)
+  (set-node-parent! child parent)
+  (set-node-index! child index)
+  (values))
+
+(define (attach-body parent call)
+  (proclaim-empty (node-parent call))
+  (proclaim-empty (lambda-body parent))
+  (set-lambda-body! parent call)
+  (set-node-parent! call parent)
+  (set-node-index! call '-1)
+  (values))
+
+; Replace node in tree with value of applying proc to node.
+; Note the fact that a change has been made at this point in the tree.
+
+(define (move node proc)
+  (let ((parent (node-parent node))
+        (index (node-index node)))
+    (detach node)
+    (let ((new (proc node)))
+      (attach parent index new)
+      (mark-changed new))))
+
+(define (move-body node proc)
+  (let ((parent (node-parent node)))
+    (detach-body node)
+    (let ((new (proc node)))
+      (attach-body parent new)
+      (mark-changed new))))
+
+; Put CALL into the tree as the body of lambda-node PARENT, making the current
+; body of PARENT the body of lambda-node CONT.
+
+(define (insert-body call cont parent)
+  (move-body (lambda-body parent)
+             (lambda (old-call)
+               (attach-body cont old-call)
+               call)))
+
+; Replace old-node with new-node, noting that a change has been made at this
+; point in the tree.
+
+(define (replace old-node new-node)
+  (let ((index (node-index old-node))
+        (parent (node-parent old-node)))
+    (mark-changed old-node)
+    (erase (detach old-node))
+    (attach parent index new-node)
+    (set-node-simplified?! new-node #f)
+    (values)))
+
+(define (replace-body old-node new-node)
+  (let ((parent (node-parent old-node)))
+    (mark-changed old-node)
+    (erase (detach-body old-node))
+    (attach-body parent new-node)
+    (set-node-simplified?! new-node #f)
+    (values)))
+
+; Starting with the parent of NODE, set the SIMPLIFIED? flags of the
+; ancestors of NODE to be #F.
+
+(define (mark-changed node)
+  (do ((p (node-parent node) (node-parent p)))
+      ((or (empty? p)
+           (not (node-simplified? p))))
+    (set-node-simplified?! p #f)))
+
+;-------------------------------------------------------------------------
+; Syntax for defining the different types of nodes.
+
+(define-syntax define-node-type
+  (lambda (form rename compare)
+    (let ((id (cadr form))
+	  (slots (cddr form)))
+      (let ((pred (concatenate-symbol id '- 'node?)))
+	`(begin (define (,pred x)
+		  (eq? ',id (node-variant x)))
+		. ,(do ((i 0 (+ i 1))
+			(s slots (cdr s))
+			(r '() (let ((n (concatenate-symbol id '- (car s)))
+				     (f (concatenate-symbol 'node-stuff- i)))
+				 `((define-node-field ,n ,pred ,f)
+				   . ,r))))
+		       ((null? s) (reverse r))))))))
+
+; These are used to rename the NODE-STUFF fields of particular node variants.
+
+(define-syntax define-node-field
+  (lambda (form rename compare)
+    (let ((id (cadr form))
+	  (predicate (caddr form))
+	  (field (cadddr form)))
+      `(begin
+	 (define (,id node)
+	   (,field (enforce ,predicate node)))
+	 (define (,(concatenate-symbol 'set- id '!) node val)
+	   (,(concatenate-symbol 'set- field '!)
+	    (enforce ,predicate node)
+	    val))))))
+
+;-------------------------------------------------------------------------
+; literals
+
+(define-node-type literal
+  value  ; the value
+  type   ; the type of the value
+  refs   ; either #F or a literal-reference record; only a few types of literal
+  )      ; literal values require reference lists
+
+(define-record-type literal-reference
+  ()
+  ((list '())  ; list of literal nodes that refer to a particular value
+   ))
+
+(define make-literal-reference-list literal-reference-maker)
+
+(define (make-literal-node value type)
+  (let ((node (make-node 'literal)))
+    (set-literal-value! node value)
+    (set-literal-type!  node type)
+    (set-literal-refs!  node #f)
+    node))
+
+(define (copy-literal-node node)
+  (let ((new (make-node 'literal))
+        (refs (literal-refs node)))
+    (set-literal-value! new (literal-value node))
+    (set-literal-type!  new (literal-type  node))
+    (set-literal-refs!  new refs)
+    (if refs (set-literal-reference-list!
+	      refs
+	      (cons new (literal-reference-list refs))))
+    new))
+
+(define (make-marked-literal value refs)
+  (let ((node (make-node 'literal)))
+    (set-literal-value!   node value)
+    (set-literal-refs!    node refs)
+    (set-literal-reference-list! refs
+				 (cons node (literal-reference-list refs)))
+    node))
+
+;-------------------------------------------------------------------------
+; These just contain an identifier.
+
+(define-node-type reference
+  variable
+  )
+
+(define (make-reference-node variable)
+  (let ((node (make-node 'reference)))
+    (set-reference-variable! node variable)
+    (set-variable-refs! variable (cons node (variable-refs variable)))
+    node))
+
+; Literal and reference nodes are leaf nodes as they do not contain any other
+; nodes.
+
+(define (leaf-node? n)
+  (or (literal-node? n)
+      (reference-node? n)))
+
+;--------------------------------------------------------------------------
+; Call nodes
+
+(define-node-type call
+  primop     ; the primitive being called
+  args       ; vector of child nodes
+  exits      ; the number of arguments that are continuations
+  source     ; source info
+  )
+
+; Create a call node with primop P, N children and EXITS exits.
+
+(define (make-call-node primop n exits)
+  (let ((node (make-node 'call)))
+    (set-call-primop! node primop)
+    (set-call-args!   node (make-vector n empty))
+    (set-call-exits!  node exits)
+    (set-call-source! node #f)
+    node))
+
+(define (call-arg call index)
+  (vector-ref (call-args call) index))
+
+(define (call-arg-count call)
+  (vector-length (call-args call)))
+
+;----------------------------------------------------------------------------
+; LAMBDA NODES
+
+(define-node-type lambda
+  body       ; the call-node that is the body of the lambda
+  variables  ; a list of variable records with #Fs for ignored positions
+  source     ; source code for the lambda (if any)
+  data       ; a LAMBDA-DATA record (lambdas have more associated data than
+  )          ; the other node types.)
+
+(define-subrecord lambda lambda-data lambda-data
+  ((name)          ; symbol          (for debugging only)
+   id              ; unique integer  (for debugging only)
+   (type))         ; PROC, KNOWN-PROC, CONT, or JUMP (maybe ESCAPE at some point)
+  ((block #f)      ; either a basic-block (for flow analysis) or a code-block
+                   ; (for code generation).
+   (env #f)        ; a record containing lexical environment data
+   (protocol #f)   ; calling protocol from the source language
+   (prev #f)       ; previous node on *LAMBDAS* list
+   (next #f)       ; next node on *LAMBDAS* list
+   ))
+
+; Doubly linked list of all non-CONT lambdas
+(define *lambdas* #f)
+
+(define (initialize-lambdas)
+  (set! *lambdas* (make-lambda-node '*lambdas* 'cont '()))
+  (link-lambdas *lambdas* *lambdas*))
+
+(define (link-lambdas node1 node2)
+  (set-lambda-prev! node2 node1)
+  (set-lambda-next! node1 node2))
+
+(define (add-lambda node)
+  (let ((next (lambda-next *lambdas*)))
+    (link-lambdas *lambdas* node)
+    (link-lambdas node next)))
+
+(define (delete-lambda node)
+  (link-lambdas (lambda-prev node) (lambda-next node))
+  (set-lambda-prev! node #f)
+  (set-lambda-next! node #f))
+
+(define (walk-lambdas proc)
+  (do ((n (lambda-next *lambdas*) (lambda-next n)))
+      ((eq? n *lambdas*))
+    (proc n))
+  (values))
+
+(define (make-lambda-list)
+  (do ((n (lambda-next *lambdas*) (lambda-next n))
+       (l '() (cons n l)))
+      ((eq? n *lambdas*)
+       l)))
+
+(define (add-lambdas nodes)
+  (for-each add-lambda nodes))
+
+;    Create a lambda node.  NAME is used as the name of the lambda node's
+; self variable.  VARS is a list of variables.  The VARIABLE-BINDER slot
+; of each variable is set to be the new lambda node.
+
+(define (make-lambda-node name type vars)
+  (let ((node (make-node 'lambda))
+        (data (lambda-data-maker name (new-id) type)))
+    (set-lambda-body!      node empty)
+    (set-lambda-variables! node vars)
+    (set-lambda-data!      node data)
+    (set-lambda-source!    node #f)
+    (for-each (lambda (var)
+		(if var (set-variable-binder! var node)))
+	      vars)
+    (if (neq? type 'cont)
+	(add-lambda node))
+    node))
+
+; Change the type of lambda-node NODE to be TYPE.  This may require adding or
+; deleting NODE from the list *LAMBDAS*.
+
+(define (change-lambda-type node type)
+  (let ((has (lambda-type node)))
+    (cond ((neq? type (lambda-type node))
+	   (set-lambda-type! node type)
+	   (cond ((eq? type 'cont)
+		  (delete-lambda node))
+		 ((eq? has 'cont)
+		  (add-lambda node)))))
+    (values)))
+
+(define (lambda-variable-count node)
+  (length (lambda-variables node)))
+
+(define (calls-known? node)
+  (neq? (lambda-type node) 'proc))
+
+(define (set-calls-known?! node)
+  (set-lambda-type! node 'known-proc))
+
+(define (proc-lambda? node)
+  (or (eq? 'proc (lambda-type node))
+      (eq? 'known-proc (lambda-type node))))
+
diff --git a/ps-compiler/node/pp-cps.scm b/ps-compiler/node/pp-cps.scm
new file mode 100644
index 0000000..28ed49a
--- /dev/null
+++ b/ps-compiler/node/pp-cps.scm
@@ -0,0 +1,355 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+; Pretty-printing the node tree
+
+; Sample output:
+
+;  34  (F_12 (C_11 UNIT_0)
+;        (SET-CONTENTS 1 C_11 UNIT_0 UNIT '0 ^F_14))
+;
+;  35   (F_14 (C_13 N_1)
+;  36     (LET* (((LOOP_73)  (CONS CELL '0))
+;  37            (()         (SET-CONTENTS LOOP_73 CELL '0 ^F_34))
+;  38            ((V_77)     (CONTENTS LOOP_73 CELL '0)))
+;           (V_77 1 C_13 N_1 '1)))
+;
+;  39    (F_34 (C_33 I_9 R_7)
+;  40      (LET* (((V_61)     (CONTENTS UNIT_0 UNIT '3))
+;  41             ((V_63)     (V_61 I_9 '0)))
+;            (TRUE? 2 ^C_58 ^C_41 V_63)))
+;
+;  42     (C_58 ()
+;           (C_33 0 R_7))
+;
+;  43     (C_41 ()
+;  44       (LET* (((V_46)     (CONTENTS UNIT_0 UNIT '2))
+;  45              ((V_56)     (V_46 I_9 R_7))
+;  46              ((V_44)     (CONTENTS UNIT_0 UNIT '1))
+;  47              ((V_54)     (V_44 I_9 '1))
+;  48              ((V_52)     (CONTENTS LOOP_73 CELL '0)))
+;             (V_52 1 C_33 V_54 V_56)))
+
+; What it means:
+
+; Variables    `<name>_<id>'         V_61
+; Primops      `<primop name>'       CONTENTS
+; Lambdas      `^<self variable>'    ^F_34
+; Literals     `'<value>'            '0
+
+;  35   (F_14 (C_13 N_1)
+; This is the header for a lambda node.  `35' is the object hash of the node.
+; `F_14' is the LAMBDA-NAME and LAMBDA-ID, `(C_13 N_1)' is the variable list.  The
+; start of this line (not counting the object hash) is indented one column
+; more than the start of the lexically superior lambda.
+
+;  36     (LET* (((LOOP_73)  (CONS CELL '0))
+;  37            (()         (SET-CONTENTS LOOP_73 CELL '0 ^F_34))
+;  38            ((V_77)     (CONTENTS LOOP_73 CELL '0)))
+;           (V_77 1 C_13 N_1 '1)))
+; This is the body of the lambda.  It is a block consisting of three simple
+; calls and then a tail recursive call.  The simple calls are in the form
+; of a LET* that allows multiple value returns.  The actual body of the
+; lambda is the call `(CONS CELL '0)'.  The continuation to this call is
+; a lambda node `(LAMBDA (LOOP_73) (SET-CONTENTS ...))'.  `36' is the
+; object hash of this continuation lambda.
+;    After the block any lambdas in the block are printed.  This lambda is
+; followed by `F_34'.
+
+; (PP-CPS node . port)
+;---------------------------------------------------------------------------
+; Print CPS node tree in linear form.  Port defaults to the current output port.
+; This just dispatches on the type of NODE.
+
+(define (pp-cps node . port)
+  (let* ((port (if (null? port) (current-output-port) (car port)))
+	 (port (if (current-column port)
+		   port
+		   (make-tracking-output-port port))))
+    (set! *rereadable?* #f)
+    (cond ((lambda-node? node)
+           (pp-cps-lambda node 4 port))
+          ((call-node? node)
+           (write-non-simple-call node port))
+          (else
+           (write-node-value node port)))
+    (newline port)
+    ((structure-ref i/o force-output) port)))
+
+(define (rereadable-pp-cps node port)
+  (set! *rereadable?* #t)
+  (pp-cps-lambda node 4 port)
+  (values))
+
+(define (indent port count)
+  (let ((count (cond ((<= (current-column port) count)
+		      (- count (current-column port)))
+		     (else
+		      (newline port)
+		      count))))
+    (do ((count count (- count 1)))
+	((>= 0 count))
+      (writec port #\space))))
+		      
+(define *rereadable?* #f)
+(define *next-pp-id* 0)
+
+(define (reset-pp-cps)
+  (set! *next-pp-id* 0))
+
+(define (next-pp-id)
+  (let ((id *next-pp-id*))
+    (set! *next-pp-id* (+ *next-pp-id* 1))
+    id))
+
+; Print a lambda node by printing its identifiers, then its call, and finally
+; any other lambdas that it includes.
+
+(define (pp-cps-lambda node indent-to port)
+  (format port "~&~%")
+  (cond ((not *rereadable?*)
+	 (node-hash node)
+	 (format port "~D" (lambda-id node))))
+  (indent port indent-to)
+  (write-lambda-header node port)
+  (let ((internal (pp-cps-body (lambda-body node) indent-to port)))
+    (writec port #\))
+    (for-each (lambda (n)
+		(pp-cps-lambda n (+ indent-to 1) port))
+	      internal)))
+
+(define (write-lambda-header node port)
+  (writec port '#\()
+  (writec port (case (lambda-type node)
+                 ((proc known-proc) #\P)
+                 ((cont)            #\C)
+                 ((jump)            #\J)
+                 ((escape)          #\E)))
+  (writec port #\space)
+  (print-lambda-name node port)
+  (writec port #\space)
+  (write-lambda-vars node port))
+
+(define (write-lambda-vars node port)
+  (let ((vars (lambda-variables node)))
+    (cond ((not (null? vars))
+           (writec port '#\()
+           (print-variable-name (car vars) port)
+           (do ((v (cdr vars) (cdr v)))
+               ((null? v))
+             (writec port '#\space)
+             (print-variable-name (car v) port))
+           (writec port '#\)))
+          (else
+           (format port "()")))))
+
+; Print the body of a lambda node.  A simple call is one that has exactly
+; one exit.  They and calls to lambda nodes are printed as a LET*.
+
+(define (pp-cps-body call indent-to port)
+  (newline port)
+  (cond ((or (simple-call? call)
+             (let-call? call))
+         (write-let* call indent-to port))
+        (else
+         (indent port (+ '2 indent-to))
+         (write-non-simple-call call port))))
+
+; Write out a series of calls as a LET*.  The LET* ends when a call is reached
+; that is neither a simple call or a call to a lambda.
+
+(define (write-let* call indent-to port)
+  (cond ((not *rereadable?*)
+	 (node-hash (call-arg call 0))
+	 (format port "~D" (lambda-id (call-arg call '0)))))
+  (indent port (+ '2 indent-to))
+  (writec port '#\()
+  (format port "LET* ")
+  (writec port '#\()
+  (let loop ((call (next-call call))
+	     (ns (write-simple-call call indent-to port)))
+    (cond ((or (simple-call? call)
+               (let-call? call))
+           (newline port)
+	   (cond ((not *rereadable?*)
+		  (format port "~D" (lambda-id (call-arg call '0)))
+		  (node-hash (call-arg call 0))))
+           (indent port (+ '9 indent-to))
+           (loop (next-call call)
+                 (append (write-simple-call call indent-to port) ns)))
+          (else
+           (writec port '#\))
+           (newline port)
+           (indent port (+ '4 indent-to))
+           (let ((ns (append (write-non-simple-call call port) ns)))
+             (writec port '#\))
+             ns)))))
+
+(define (simple-call? call)
+  (and (= '1 (call-exits call))
+       (not (lambda-block (call-arg call 0)))))
+
+(define (let-call? call)
+  (calls-this-primop? call 'let))
+
+; Get the call that follows CALL in a LET*.
+
+(define (next-call call)
+  (lambda-body (call-arg call '0)))
+
+; Write out one line of a LET*.
+
+(define (write-simple-call call indent-to port)
+  (if (let-call? call)
+      (write-let-call call indent-to port)
+      (really-write-simple-call call indent-to port)))
+
+; Write the variables bound by the continuation and then the primop and
+; non-continuation arguments of the call.
+
+(define (really-write-simple-call call indent-to port)
+  (writec port '#\()
+  (write-lambda-vars (call-arg call '0) port)
+  (indent port (+ indent-to '21))
+  (writec port '#\()
+  (format port "~S" (primop-id (call-primop call)))
+  (write-call-args call '1 port)
+  (writec port '#\))
+  (find-lambda-nodes call 1))
+
+; Write the variables of the lambda and then the values of the arguments.
+
+(define (write-let-call call indent-to port)
+  (writec port '#\()
+  (write-lambda-vars (call-arg call '0) port)
+  (cond ((= '1 (vector-length (call-args call)))
+         (writec port '#\))
+         '())
+        (else
+	 (writec port #\*)
+         (indent port (+ indent-to '21))
+         (write-node-value (call-arg call '1) port)
+         (write-call-args call '2 port)
+	 (find-lambda-nodes call 1))))
+
+(define (find-lambda-nodes call start)
+  (reverse (let label ((call call) (start start) (ls '()))
+	     (do ((i start (+ i 1))
+		  (ls ls (let ((arg (call-arg call i)))
+			   (cond ((call-node? arg)
+				  (label arg 0 ls))
+				 ((lambda-node? arg)
+				  (cons arg ls))
+				 (else ls)))))
+		 ((>= i (call-arg-count call))
+		  ls)))))
+
+; Write out a call that ends a LET* block.
+
+(define (write-non-simple-call call port)
+  (writec port '#\()
+  (format port "~A ~D" (primop-id (call-primop call)) (call-exits call))
+  (write-call-args call '0 port)
+  (find-lambda-nodes call 0))
+
+; Write out the arguments of CALL starting with START.
+
+(define (write-call-args call start port)
+  (let* ((vec (call-args call))
+         (len (vector-length vec)))
+    (do ((i start (+ i '1)))
+        ((>= i len))
+      (writec port '#\space)
+      (write-node-value (vector-ref vec i) port))
+    (writec port '#\))))
+
+; Print out a literal value.
+
+(define (cps-print-literal value port)
+  (format port "'~S" value))
+
+; Dispatch on the type of NODE to get the appropriate printing method.
+
+(define (write-node-value node port)
+  (cond ((not (node? node))
+         (format port "{not a node}"))
+        ((lambda-node? node)
+         (writec port '#\^)
+         (print-lambda-name node port))
+	((call-node? node)
+	 (format port "(~S" (primop-id (call-primop node)))
+	 (write-call-args node '0 port))
+        ((literal-node? node)
+         (cps-print-literal (literal-value node) port))
+        ((reference-node? node)
+         (print-variable-name (reference-variable node) port))
+        (else
+         (bug "WRITE-NODE-VALUE got funny node ~S" node))))
+
+; Printing variables and lambda nodes
+
+; #T if variables are supposed to print as the name of the register containing
+; them instead of their name.
+
+(define *pp-register-names?* '#f)
+
+; A whole bunch of different entry points for printing variables in slightly
+; different ways.
+
+(define (print-variable-name var port)
+  (cond ((not var)
+         (format port "#f"))
+;        ((and *pp-register-names?*
+;              (reg? (variable-register var)))
+;         (format port "~S" (reg-name (variable-register var))))
+        (else
+	 (let ((id (cond ((not *rereadable?*)
+			  (variable-id var))
+			 ((variable-flag var)
+			  => identity)
+			 (else
+			  (let ((id (next-pp-id)))
+			    (set-variable-flag! var id)
+			    id)))))
+	   (format port "~S_~S" (variable-name var) id)))))
+
+; Same as the above without the check for a register.
+
+(define (print-variable-plain-name var port)
+  (cond ((not var)
+         (format port "#f"))
+        (else
+         (format port "~S_~D" (variable-name var) (variable-id var)))))
+
+; Return the name as a string.
+
+(define (variable-print-name var)
+  (print-variable-name var '#f))
+
+; Return the name as a symbol.
+
+(define (variable-unique-name var)
+  (string->symbol (variable-print-name var)))
+
+; Printing lambda-nodes as variables
+
+(define (print-lambda-name lnode port)
+  (let ((id (cond ((not *rereadable?*)
+		    (lambda-id lnode))
+		  ((node-flag lnode)
+		   => identity)
+		  (else
+		   (let ((id (next-pp-id)))
+		     (set-node-flag! lnode id)
+		     id)))))
+    (format port "~S_~D" (lambda-name lnode) id)))
+
+(define (lambda-print-name lnode)
+  (print-lambda-name lnode '#f))
+
+(define (lambda-unique-name lnode)
+  (string->symbol (lambda-print-name lnode)))
+
+
+
+
+
diff --git a/ps-compiler/node/primop.scm b/ps-compiler/node/primop.scm
new file mode 100644
index 0000000..97027eb
--- /dev/null
+++ b/ps-compiler/node/primop.scm
@@ -0,0 +1,128 @@
+
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+;   The information about a primitive operation.
+
+(define-record-type primop
+  (id             ; Symbol identifying this primop
+
+   trivial?       ; #t if this primop has does not require a continuation
+   side-effects   ; side-effects of this primop
+
+   simplify-call-proc ; Simplify method
+   primop-cost-proc   ; Cost of executing this operation
+                      ; (in some undisclosed metric)
+   return-type-proc   ; Give the return type (for trivial primops only)
+   proc-data      ; Record containing more data for the procedure primops
+   cond-data      ; Record containing more data for conditional primops
+   )
+  (code-data      ; Code generation data
+   ))
+
+(define-record-discloser type/primop
+  (lambda (primop)
+    (list 'primop (object-hash primop) (primop-id primop))))
+
+(define all-primops (make-vector primop-count))
+
+(define (make-primop id trivial? side-effects simplify cost type)
+  (let ((enum (name->enumerand id primop))
+	(primop (primop-maker id trivial? side-effects simplify cost type #f #f)))
+    (if enum
+	(vector-set! all-primops enum primop))
+    primop))
+
+(define (get-primop enum)
+  (vector-ref all-primops enum))
+
+(define-local-syntax (define-primop-method id args)
+  `(define (,id  . ,args)
+     ((,(concatenate-symbol 'primop- id '- 'proc) (call-primop ,(car args)))
+      . ,args)))
+
+(define-primop-method primop-cost (call))
+(define-primop-method simplify-call (call))
+
+(define (trivial-call-return-type call)
+  ((primop-return-type-proc (call-primop call)) call))
+
+;-------------------------------------------------------------------------------
+; procedure primops
+
+(define-subrecord primop primop-proc-data primop-proc-data
+  (call-index              ; index of argument being called
+   )
+  ())
+
+(define (primop-procedure? primop)
+  (if (primop-proc-data primop) #t #f))
+
+; (call <cont> <proc-var> . <args>)
+; (tail-call <cont-var> <proc-var> . <args>)
+; (return <proc-var> . <args>)
+; (jump   <proc-var> . <args>)
+; (throw  <proc-var> . <args>)
+;
+; (unknown-call <cont> <proc-var> . <args>)
+; (unknown-tail-call <cont-var> <proc-var> . <args>)
+; (unknown-return <proc-var> . <args>)
+
+(define (make-proc-primop id side-effects simplify cost index)
+  (let* ((enum (name->enumerand id primop))
+	 (data (primop-proc-data-maker index))
+	 (primop (primop-maker id #f side-effects simplify cost #f data #f)))
+    (vector-set! all-primops enum primop)
+    primop))
+
+;-------------------------------------------------------------------------------
+; conditional primops
+
+(define-subrecord primop primop-cond-data primop-cond-data
+  (expand-to-conditional-proc     ; Expand this call to a conditional
+   simplify-conditional?-proc     ; Can this conditional be simplified
+   )
+  ())
+
+(define-primop-method expand-to-conditional (call))
+(define-primop-method simplify-conditional? (call index value))
+
+(define (primop-conditional? primop)
+  (if (primop-cond-data primop) #t #f))
+
+(define (make-conditional-primop id side-effects simplify cost expand simplify?)
+  (let* ((enum (name->enumerand id primop))
+	 (data (primop-cond-data-maker expand simplify?))
+	 (primop (primop-maker id #f side-effects simplify cost #f #f data)))
+    (if enum (vector-set! all-primops enum primop))
+    primop))
+
+;-------------------------------------------------------------------------------
+; Random constants for location calls:
+
+;  ($CONTENTS     <thing> <type> <offset> <rep>)
+;  ($SET-CONTENTS <cont> <thing> <type> <offset> <rep> <value>)
+;                    0      1       2       3      4 
+
+(define loc/owner    0)
+(define loc/type     1)
+(define loc/rep      2)
+
+(define set/owner    1)
+(define set/type     2)
+(define set/rep      3)
+(define set/value    4)
+
+; For slots that do not contain code pointers:
+;  ($CLOSURE        <cont> <env> <slot>)
+;  ($SET-CLOSURE    <cont> <env> <slot> <value>)
+; For slots that do contain code pointers:
+;  ($MAKE-PROCEDURE <cont> <env> <slot>)
+;  ($SET-CODE       <cont> <env> <slot> <value>)
+; For known calls to slots that contain code pointers:
+;  ($ENV-ADJUST     <cont> <env> <slot>)
+;                     0      1      2
+
+(define env/owner    0)
+(define env/offset   1)
+(define env/value    2)
+
diff --git a/ps-compiler/node/vector.scm b/ps-compiler/node/vector.scm
new file mode 100644
index 0000000..16ac9eb
--- /dev/null
+++ b/ps-compiler/node/vector.scm
@@ -0,0 +1,212 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+;----------------------------------------------------------------------------
+; STORING NODE TREES IN VECTORS
+;----------------------------------------------------------------------------
+
+; The use of OTHER and GLOBAL depends on whether NODE->VECTOR or VECTOR->NODE
+
+(define-record-type vec
+ (vector    ; an expanding vector (NODE->VECTOR) or just a vector (VECTOR->NODE)
+  (index)   ; the index of the next empty slot or the next thing to read
+  locals    ; vector of local variables (VECTOR->NODE only)
+  )
+ ())
+
+(define make-vec vec-maker)
+
+; Add value as the next thing in the VEC.
+
+(define (add-datum vec value)
+  (xvector-set! (vec-vector vec) (vec-index vec) value)
+  (set-vec-index! vec (+ 1 (vec-index vec))))
+
+;   Convert a node into a vector
+;
+; literal       => QUOTE <literal> <rep>
+; reference     => <index of the variable's name in vector> if lexical, or
+;                  GLOBAL <variable> if it isn't
+; lambda        => LAMBDA <stuff> #vars <variable names+reps> <call>
+; call          => CALL <source> <primop> <exits> <number of args> <args>
+
+; Preserve the node as a vector.
+
+(define (node->vector node)
+  (let ((vec (make-vec (make-xvector #f) 0 #f)))
+    (real-node->vector node vec)
+    (xvector->vector (vec-vector vec))))
+  
+; The main dispatch
+
+(define (real-node->vector node vec)
+  (case (node-variant node)
+    ((literal)
+     (literal->vector node vec))
+    ((reference)
+     (reference->vector node vec))
+    ((lambda)
+     (lambda->vector node vec))
+    ((call)
+     (add-datum vec 'call)
+     (call->vector node vec))
+    (else
+     (bug "node->vector got funny node ~S" node))))
+
+; VARIABLE-FLAGs are used to mark variables with their position in the
+; vector.
+
+(define (lambda->vector node vec)
+  (add-datum vec 'lambda)
+  (add-datum vec (lambda-name node))
+  (add-datum vec (lambda-type node))
+  (add-datum vec (lambda-protocol node))
+  (add-datum vec (lambda-source node))
+  (add-datum vec (lambda-variable-count node))
+  (for-each (lambda (var)
+	      (cond ((not var)
+		     (add-datum vec #f))
+		    (else
+		     (set-variable-flag! var (vec-index vec))
+		     (add-datum vec (variable-name var))
+		     (add-datum vec (variable-type var)))))
+	    (lambda-variables node))
+  (call->vector (lambda-body node) vec)
+  (for-each (lambda (var)
+	      (if var
+		  (set-variable-flag! var #f)))
+	    (lambda-variables node)))
+
+; If VAR is bound locally, then put the index of the variable within the vector
+; into the vector.
+
+(define (reference->vector node vec)
+  (let ((var (reference-variable node)))
+    (cond ((not (variable-binder var))
+           (add-datum vec 'global)
+           (add-datum vec var))
+          ((integer? (variable-flag var))
+           (add-datum vec (variable-flag var)))
+          (else
+           (bug "variable ~S has no vector location" var)))))
+
+(define (literal->vector node vec)
+  (let ((value (literal-value node)))
+    (add-datum vec 'quote)
+    (add-datum vec (literal-value node))
+    (add-datum vec (literal-type node))))
+
+; This counts down so that the continuation will be done after the arguments.
+; Why does this matter?
+
+(define (call->vector node vec)
+  (let* ((args (call-args node))
+         (len (vector-length args)))
+    (add-datum vec (call-source node))
+    (add-datum vec (call-primop node))
+    (add-datum vec (call-exits node))
+    (add-datum vec len)
+    (do ((i (- len 1) (- i 1)))
+        ((< i 0))
+      (real-node->vector (vector-ref args i) vec))))
+
+;----------------------------------------------------------------------------
+; TURNING VECTORS BACK INTO NODES
+;----------------------------------------------------------------------------
+
+(define (vector->node vector)
+  (if (not (vector? vector))
+      (bug "VECTOR->NODE got funny value ~S~%" vector)
+      (let ((vec (make-vec vector -1 (make-vector (vector-length vector)))))
+	(real-vector->node vec))))
+
+(define (vector->leaf-node vector)
+  (case (vector-ref vector 0)
+    ((quote global)
+     (vector->node vector))
+    (else #f)))
+
+; Pop the next thing off of the vector (which is really a (<vector> . <index>)
+; pair).
+
+(define (get-datum vec)
+  (let ((i (+ (vec-index vec) 1)))
+    (set-vec-index! vec i)
+    (vector-ref (vec-vector vec) i)))
+
+; This prevents the (unecessary) resimplification of recreated nodes.
+
+(define (real-vector->node vec)
+  (let ((node (totally-real-vector->node vec)))
+    (set-node-simplified?! node #t)
+    node))
+
+; Dispatch on the next thing in VEC.
+
+(define (totally-real-vector->node vec)
+  (let ((exp (get-datum vec)))
+    (cond ((integer? exp)
+           (make-reference-node (vector-ref (vec-locals vec) exp)))
+          (else
+           (case exp
+             ((lambda)
+              (vector->lambda-node vec))
+             ((quote)
+              (let* ((value (get-datum vec))
+                     (rep   (get-datum vec)))
+                (make-literal-node value rep)))
+             ((global)
+	      (make-reference-node (get-datum vec)))
+	     ((call)
+	      (vector->call-node vec))
+	     ((import)  ; global variable from a separate compilation
+	      (make-reference-node (lookup-imported-variable (get-datum vec))))
+             (else
+              (no-op
+               (bug '"real-vector->node got an unknown code ~S" exp))))))))
+
+(define (vector->lambda-node vec)
+  (let* ((name     (get-datum vec))
+         (type     (get-datum vec))
+	 (protocol (get-datum vec))
+	 (source   (get-datum vec))
+         (count    (get-datum vec))
+         (vars (do ((i 0 (+ i 1))
+                    (v '() (cons (vector->variable vec) v)))
+                   ((>= i count) v)))
+         (node (make-lambda-node name type (reverse! vars))))
+    (set-lambda-protocol! node protocol)
+    (set-lambda-source! node source)
+    (attach-body node (vector->call-node vec))
+    (set-node-simplified?! (lambda-body node) #t)
+    node))
+
+; Replace a variable name with a new variable.
+
+(define (vector->variable vec)
+  (let ((name (get-datum vec)))
+    (if name
+        (let ((var (make-variable name (get-datum vec))))
+          (vector-set! (vec-locals vec) (+ -1 (vec-index vec)) var)
+          var)
+        #f)))
+
+(define (vector->call-node vec)
+  (let* ((source (get-datum vec))
+	 (primop (let ((p (get-datum vec)))
+		   (if (primop? p)
+		       p
+		       (lookup-primop p))))
+	 (exits  (get-datum vec))
+         (count  (get-datum vec))
+         (node (make-call-node primop count exits)))
+    (do ((i (- count 1) (- i 1)))
+        ((< i 0))
+      (attach node i (real-vector->node vec)))
+    (set-call-source! node source)
+    node))
+
+
+
+
+
diff --git a/ps-compiler/package-defs.scm b/ps-compiler/package-defs.scm
new file mode 100644
index 0000000..306dcc1
--- /dev/null
+++ b/ps-compiler/package-defs.scm
@@ -0,0 +1,235 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+; The intermediate language (node tree)
+; The structures VARIABLE and PRIMOP are contained in NODE.  They are used
+; in client language code where the NODE- names conflict.
+
+(define-structures ((node     node-interface)
+		    (variable variable-interface)
+		    (primop   primop-interface))
+  (open scheme big-scheme comp-util arch parameters
+	defrecord)
+  (for-syntax (open scheme big-scheme let-nodes))
+  (begin 
+    (define-syntax let-nodes
+      (lambda (form rename compare)
+	(expand-let-nodes form rename compare))))
+  (files (node node)         ; variable and node data structures
+	 (node primop)       ; primop data structure
+	 (node node-util)    ; various small utilities
+	 (node node-equal))) ; node equality
+
+;(define node
+;  (let ()
+;    (define-structure let-nodes (export expand-let-nodes)
+;      (open scheme big-scheme arch)
+;      (files (node let-nodes)))
+;    (define-structures ((node     node-interface)
+;                        (variable variable-interface)
+;                        (primop   primop-interface))
+;      (open scheme big-scheme comp-util arch parameters)
+;      (for-syntax (open scheme big-scheme let-nodes))
+;      (begin 
+;        (define-syntax let-nodes
+;          (lambda (form rename compare)
+;            (expand-let-nodes form rename compare))))
+;      (files (node node)         ; variable and node data structures
+;             (node primop)       ; primop data structure
+;             (node node-util)    ; various small utilities
+;             (node node-equal)   ; node equality
+;             (node leftovers)))  ; more node utilities
+;    node))
+
+; Pretty printer
+
+(define-structure pp-cps (export pp-cps)
+  (open scheme big-scheme comp-util node structure-refs)
+  (access i/o)  ; force-output
+  (files (node pp-cps)))
+
+; Expander for LET-NODES, a macro for creating interconnected nodes.
+	 
+(define-structure let-nodes (export expand-let-nodes)
+  (open scheme big-scheme arch)
+  (files (node let-nodes)))
+
+; Compiler Parameters
+; This allows client languages to supply parameters to the compiler
+; without introducing circular module dependencies.
+
+(define-structures ((parameters parameter-interface)
+		    (set-parameters (export set-compiler-parameter!)))
+  (open scheme big-scheme)
+  (files param))
+
+; An enumerated type defining the standard primops.
+
+(define-structure arch (export (primop :syntax) primop-count)
+  (open scheme enumerated)
+  (files (node arch)))
+
+; linearizing node trees for later reuse
+
+(define-structure node-vector (export node->vector
+				      vector->node
+				      vector->leaf-node)
+  (open scheme big-scheme comp-util node parameters
+	defrecord)
+  (files (node vector)))
+
+; Translating the input forms into simplified node trees
+
+(define-structures ((front       front-interface)
+		    (front-debug front-debug-interface))
+  (open scheme big-scheme comp-util node simplify parameters jump
+	remove-cells flow-values)
+  (files (front top)))       ; main entry points and debugging utilities
+
+(define-structure cps-util (export cps-call cps-sequence)
+  (open scheme big-scheme comp-util node
+	define-record-types)
+  (files (front cps)))
+
+; Converting tail-recursive calls to jumps
+
+(define-structure jump (export integrate-jump-procs!
+			       find-jump-procs
+			       procs->jumps)
+  (open scheme big-scheme comp-util node parameters ssa
+	define-record-types)
+  (files (front jump)))
+
+; Program simplification and partial evaluation
+
+(define-structures ((simplify (export simplify-node))
+		    (simplify-internal simplify-internal-interface))
+  (open scheme big-scheme comp-util node parameters node-vector)
+  (for-syntax (open scheme big-scheme simp-patterns))
+  (begin
+    (define-syntax pattern-simplifier
+      (lambda (form rename compare)
+	(make-pattern-simplifier (cdr form))))) ; from SIMP-PATTERNS
+  (files (simp simplify)  ; main entry point and driver
+	 (simp call)))    ; simplifiers for some of the standard primops
+
+; Simplifying calls to lambda nodes
+
+(define-structure simplify-let (export simplify-let)
+  (open scheme big-scheme comp-util node parameters
+	simplify-join simplify-internal)
+  (files (simp let)))
+
+; Substituting lambda nodes that are bound by calls to lambda nodes,
+; trying to maximize the further simplification opportunites while
+; minimizing code expansion.
+
+(define-structure simplify-join (export substitute-join-arguments)
+  (open scheme big-scheme comp-util node)
+  (files (simp join)))
+
+; The expander for PATTERN-SIMPLIFIER, a macro for writing algebraic
+; transformations.
+
+(define-structure simp-patterns (export make-pattern-simplifier)
+  (open scheme big-scheme defrecord)
+  (files (simp pattern)))
+
+; Replacing cells with values passed as parameters, currently empty
+; and unused (the code has not been made compatible with the current
+; version of the compiler).
+
+(define-structure remove-cells (export remove-cells-from-tree)
+  (open scheme big-scheme)
+  (begin
+    (define (remove-cells-from-tree . stuff)
+      (error "REMOVE-CELLS-FROM-TREE is undefined"))))
+
+; Flow analysis, also currently empty and unused for the same reason.
+
+(define-structure flow-values (export flow-values)
+  (open scheme big-scheme)
+  (begin
+    (define (flow-values . stuff)
+      (error "FLOW-VALUES is undefined"))))
+
+; A random collection of utilities.
+
+(define-structure comp-util utilities-interface
+  (open scheme big-scheme structure-refs expanding-vectors)
+  (for-syntax (open scheme big-scheme))
+  (access primitives features)
+  (files (util syntax)        ; macro for defining subrecords
+	 (util util)))        ; random utilities
+
+(define-structure expanding-vectors (export make-xvector
+					    xvector-length
+					    xvector-ref
+					    xvector-set!
+					    xvector-length
+					    xvector->vector)
+  (open scheme define-record-types)
+  (files (util expand-vec)))
+
+(define-interface transitive-interface
+  (export make-graph-from-predecessors
+	  make-graph-from-successors
+	  transitive-or! transitive-or-with-kill! transitive-or-with-pass!
+	  transitive-and! transitive-and-with-kill! transitive-and-with-pass!))
+
+(define-structure transitive transitive-interface
+  (open scheme big-scheme integer-sets defrecord)
+  (optimize auto-integrate)
+  (files (util transitive)))
+
+(define-interface integer-set-interface
+  (export make-empty-integer-set
+	  add-to-integer-set
+	  integer-set-not
+	  integer-set-ior
+	  integer-set-and
+	  integer-set-subtract
+	  integer-set-equal?
+	  map-over-integer-set))
+
+(define-structure integer-sets integer-set-interface
+  (open scheme bitwise bigbit)
+  (optimize auto-integrate)
+  (files (util z-set)))
+
+(define-structure strongly-connected (export strongly-connected-components)
+  (open scheme big-scheme defrecord)
+  (optimize auto-integrate)
+  (files (util strong)))
+
+(define-structure dominators (export find-dominators!)
+  (open scheme big-scheme comp-util
+	define-record-types)
+  (optimize auto-integrate)
+  (files (util dominators)))
+
+(define-structure ssa (export graph->ssa-graph! find-joins)
+  (open scheme big-scheme dominators
+	define-record-types)
+  (optimize auto-integrate)
+  (files (util ssa)))
+
+; Vectors of bytes, a renaming of Scheme 48's code vectors.
+
+(define-structure byte-vectors compiler-byte-vector-interface
+  (open scheme code-vectors bitwise signals)
+  (optimize auto-integrate)
+  (files (util byte-vector)))
+
+; A version of READ that annotates pairs with source file, line, and
+; column information.
+
+(define-structure annotated-read annotated-read-interface
+  ; this is correct for linking, but doesn't work when loading
+  ;(open defrecord extended-ports primitives scheme assembler)
+  (open scheme big-scheme primitives fluids assembler)
+  (files (prescheme track-read)))
+
+
+
+
diff --git a/ps-compiler/param.scm b/ps-compiler/param.scm
new file mode 100644
index 0000000..49ecad6
--- /dev/null
+++ b/ps-compiler/param.scm
@@ -0,0 +1,42 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+; Parameterizing the compiler.
+
+(define lookup-primop 'unset-compiler-parameter)
+(define lookup-imported-variable 'unset-compiler-parameter)
+	  
+(define type/unknown 'unset-compiler-parameter)
+(define type-eq? 'unset-compiler-parameter)
+
+(define lambda-node-type 'unset-compiler-parameter)
+
+(define true-value  'unset-compiler-parameter)
+(define false-value 'unset-compiler-parameter)
+
+(define determine-lambda-protocol       'unset-compiler-parameter)
+(define determine-continuation-protocol 'unset-compiler-parameter)
+
+(define (set-compiler-parameter! name value)
+  (case name
+    ((lookup-primop)
+     (set! lookup-primop value))
+    ((lookup-imported-variable)
+     (set! lookup-imported-variable value))
+    ((type/unknown)
+     (set! type/unknown value))
+    ((type-eq?)
+     (set! type-eq? value))
+    ((lambda-node-type)
+     (set! lambda-node-type value))
+    ((true-value)
+     (set! true-value value))
+    ((false-value)
+     (set! false-value value))
+    ((determine-lambda-protocol)
+     (set! determine-lambda-protocol value))
+    ((determine-continuation-protocol)
+     (set! determine-continuation-protocol value))
+    (else
+     (error "unknown compiler parameter ~S ~S" name value))))
+
diff --git a/ps-compiler/prescheme/c-call.scm b/ps-compiler/prescheme/c-call.scm
new file mode 100644
index 0000000..3ea44ac
--- /dev/null
+++ b/ps-compiler/prescheme/c-call.scm
@@ -0,0 +1,353 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+; Generating C code for a call
+
+(define (call->c node port indent)
+  (let loop ((node node))
+    (if (primop-call->c node port indent)
+	(loop (lambda-body (call-arg node 0))))))
+
+(define (primop-call->c node port indent)
+  (let ((primop (call-primop node)))
+    (if (and (simple-c-primop? primop)
+	     (= 0 (call-exits node)))
+	(generate-simple-assignment primop node port indent)
+	(primop-generate-c primop node port indent))
+    (and (= 1 (call-exits node))
+	 (not (goto-call? node)))))
+
+(define (c-value node port)
+  (cond ((string? node)
+	 (display node port))
+	((not (node? node))
+	 (display node port))
+	((reference-node? node)
+	 (c-variable (reference-variable node) port))
+	((literal-node? node)
+	 (c-literal-value (literal-value node) (literal-type node) port))
+	((call-node? node)        ; must be simple
+	 (let ((parens? (call-needs-parens? node)))
+	   (if parens? (write-char #\( port))
+	   (primop-generate-c (call-primop node) node port 0)
+	   (if parens? (write-char #\) port))))
+	(else
+	 (bug "odd node in C-VALUE ~S" node))))
+
+(define (c-literal-value value type port)
+  (let ((value (cond ((integer? value) value)
+		     ((eq? value #f) 0)
+		     ((eq? value #t) 1)
+		     ((string? value) value)
+		     ((external-value? value) value)
+		     ((external-constant? value) value)
+		     ((char? value) (char->ascii value))
+		     (else
+		      (error "cannot translate literal to C ~A" value)))))
+    (cond ((integer? value)
+	   (format port "~D" value))
+	  ((string? value)
+	   (c-string-constant value port))
+	  ((external-value? value)
+	   (display (external-value-string value) port))
+	  ((external-constant? value)
+	   (display (external-constant-c-string value) port))
+	  (else
+	   (display value port)))))
+
+(define (c-string-constant string port)
+  (write-char #\" port)
+  (do ((i 0 (+ i 1)))
+      ((= i (string-length string)))
+    (let ((char (string-ref string i)))
+      (case char
+	((#\newline)
+	 (write-char #\\ port)
+	 (write-char #\n port))
+	((#\")
+	 (write-char #\\ port)
+	 (write-char #\" port))
+	((#\\)
+	 (write-char #\\ port)
+	 (write-char #\\ port))
+	(else
+	 (write-char char port)))))
+  (write-char #\" port))
+
+;	(case (base-type-size (maybe-follow-uvar type))
+;	  ((1)
+;	   (let ((new-value (if (>= value 0)
+;				(bitwise-and value 255)
+;				(error "can't translate negative character constants to C ~S"
+;				       value))))
+;	     (format port "'\\~D~D~D'"
+;		     (remainder (quotient new-value 64) 8)
+;		     (remainder (quotient new-value 8) 8)
+;		     (remainder new-value 8))))
+;	  ((2)
+;	   (format port "~D" value))
+;	  ((4)
+;	   (format port "~DL" value))
+;	  (else
+;	   (error "cannot translate literal type to C ~S" type)))
+
+; Cut down on the number of unnecessary parentheses.  We don't go so far as
+; to pay attention to C's precedence rules.
+
+(define (call-needs-parens? call)
+  (and (not (and (eq? 'contents (primop-id (call-primop call)))
+		 (eq? 'global (literal-value (call-arg call loc/type)))))
+       (let ((parent (node-parent call)))
+	 (and (node? parent)
+	      (call-node? parent)
+	      (not (eq? 'let
+			(primop-id (call-primop parent))))))))
+
+; Each local variable has a unique integer used to disambiguate in the
+; C code.  Using our own, instead of what variables already have, keeps
+; the numbers smaller and more readable.
+
+(define *c-variable-id* '0)
+
+(define (next-c-variable-id)
+  (let ((id *c-variable-id*))
+    (set! *c-variable-id* (+ *c-variable-id* 1))
+    id))
+
+(define (c-variable-id var)
+  (if (integer? (variable-generate var))
+      (variable-generate var)
+      (let ((id (next-c-variable-id)))
+	(set! *local-vars* (cons var *local-vars*))
+	(set-variable-generate! var id)
+	id)))
+
+(define (c-variable var port)
+  (really-c-variable var port #t))
+
+(define (c-variable-no-shadowing var port)
+  (really-c-variable var port #f))
+
+(define (really-c-variable var port shadow?)
+  (cond ((string? var)
+	 (display var port))
+	((symbol? var)
+	 (display var port))
+	((not (variable? var))
+	 (bug "funny value for C-VARIABLE ~S" var))
+	((not (variable-binder var))
+	 (cond ((and shadow?
+		     (memq? 'shadowed (variable-flags var)))
+		(writec port '#\R))
+	       ((generated-top-variable? var)
+		(writec port '#\H)))
+	 (write-c-identifier (variable-name var) port)
+	 (if (generated-top-variable? var)
+	     (display (c-variable-id var) port)))
+	(else
+	 ;		  (if (= (c-variable-id var) 944)
+	 ;		      (breakpoint "writing 944"))
+	 (write-c-identifier (variable-name var) port)
+	 (write-char '#\_ port)
+	 (display (c-variable-id var) port)
+	 (write-char '#\X port))))
+
+;==============================================================================;
+; Scheme identifiers contain many characters that are not legal in C
+; identifiers.  Luckily C is case-sensitive and Scheme is not.
+
+(define char-translations
+  (let* ((count number-of-char-codes)
+         (string (make-string count)))
+    (do ((i '0 (+ i '1)))
+        ((>= i count))
+      (let ((char (ascii->char i)))
+        (string-set! string i
+		     (cond ((and (char-alphabetic? char)
+				 (char=? char
+					 (string-ref (symbol->string
+						      (string->symbol
+						       (list->string
+							(list char))))
+						     0)))
+			    (char-downcase char))
+			   ((char-numeric? char)
+			    char)
+			   (else
+			    (ascii->char 0))))))
+    (string-set! string (char->ascii '#\+) '#\A)
+    (string-set! string (char->ascii '#\!) '#\B)
+    (string-set! string (char->ascii '#\:) '#\C)
+    (string-set! string (char->ascii '#\.) '#\D)
+    (string-set! string (char->ascii '#\=) '#\E)
+    (string-set! string (char->ascii '#\>) '#\G)
+    ; used for flattened closures             H
+    ; precedes C keywords                     K
+    (string-set! string (char->ascii '#\<) '#\L)
+    (string-set! string (char->ascii '#\?) '#\P)
+    (string-set! string (char->ascii '#\%) '#\Q)
+    (string-set! string (char->ascii '#\*) '#\S)
+    ; used for tail-recursive procedures      T
+    (string-set! string (char->ascii '#\/) '#\U)
+    (string-set! string (char->ascii '#\#) '#\W)
+    ; follows lexical identifiers             X
+    ; used by the multi-procedure block code  Z
+    (string-set! string (char->ascii '#\-) '#\_)
+    string))
+
+; This needs to check for C keywords (just precede with K)
+
+(define (write-c-identifier symbol port)
+  (if (table-ref c-keywords symbol)
+      (writec port '#\K))
+  (let ((string (symbol->string symbol)))
+    (do ((i 0 (+ i 1)))
+	((>= i (string-length string)))
+      (let* ((char (string-ref string i))
+	     (out (string-ref char-translations (char->ascii char))))
+	(if (= 0 (char->ascii out))
+	    (bug "cannot translate ~S from ~A into C" char string)
+	    (writec port out))))
+    (values)))
+
+(define (c-ify symbol)
+  (call-with-string-output-port
+    (lambda (port)
+      (write-c-identifier symbol port))))
+
+(define c-keywords (make-table))
+
+(for-each (lambda (k)
+	    (table-set! c-keywords k #t))
+	  '(
+	    auto     double int      struct
+	    break    else   long     switch
+	    case     enum   register typedef
+	    char     extern return   union
+	    const    float  short    unsigned
+	    continue for    signed   void
+	    default  goto   sizeof   volatile
+	    do       if     static   while
+	    ))
+
+;==============================================================================;
+
+(define (simple-c-primop op call port)
+  (case (call-arg-count call)
+    ((1)
+     (generate-simple-c-monop-call op (call-arg call 0) port))
+    ((2)
+     (destructure ((#(arg1 arg2) (call-args call)))
+       (generate-simple-c-binop-call op arg1 arg2 port)))
+    (else
+     (bug "funny call to SIMPLE-C-PRIMOP ~S" call))))
+
+(define (generate-simple-c-binop-call op arg1 arg2 port)
+  (c-value arg1 port)
+  (writec port '#\space)
+  (display op port)
+  (writec port '#\space)
+  (c-value arg2 port)
+  (values))
+
+(define (generate-simple-c-monop-call op arg1 port)
+  (display op port)
+  (writec port '#\space)
+  (c-value arg1 port)
+  (values))
+
+(define (generate-simple-assignment primop call port indent)
+  (let ((var (car (lambda-variables (call-arg call 0)))))
+    (c-assign-to-variable var port indent)
+    (primop-generate-c primop call port #f)
+    (writec port '#\;)
+    (values)))
+
+(define (c-assignment var value port indent)
+  (c-assign-to-variable var port indent)
+  (c-value value port)
+  (writec port '#\;))
+
+(define (c-assign-to-variable var port indent)
+  (indent-to port indent)
+  (cond ((or (not (variable? var))
+	     (and (or (used? var)
+		      (global-variable? var))
+		  (not (eq? type/unit (final-variable-type var)))))
+	 (c-variable var port)
+	 (display " = " port))))
+
+;==============================================================================;
+
+(define (known-variable-reference node)
+  (cond ((reference-node? node)
+	 (let ((var (reference-variable node)))
+	   (if (global-variable? var) var #f)))
+	(else #f)))
+
+(define (write-value-list args start port)
+  (writec port '#\()
+  (really-write-value-list args start '() port)
+  (writec port '#\)))
+
+(define (write-value-list-with-extras args start extras port)
+  (writec port '#\()
+  (really-write-value-list args start extras port)
+  (writec port '#\)))
+
+(define (really-write-value-list args start extras port)
+  (let ((len (vector-length args)))
+    (cond ((> len start)
+           (c-value (vector-ref args start) port)
+           (do ((i (+ start '1) (+ i '1)))
+               ((>= i len) (values))
+             (writec port '#\,)
+             (writec port '#\space)
+	     (c-value (vector-ref args i) port))
+	   (write-comma-value-list extras port))
+	  ((not (null? extras))
+	   (c-value (car extras) port)
+	   (write-comma-value-list (cdr extras) port)))))
+	   
+(define (write-comma-value-list args port)
+  (for-each (lambda (arg)
+	      (writec port '#\,)
+	      (writec port '#\space)
+	      (c-value arg port))
+	    args))
+
+(define (write-value+result-var-list args start vars port)
+  (writec port '#\()
+  (really-write-value-list args start '() port)
+  (cond ((not (null? vars))
+	 (if (> (vector-length args) start)
+	     (display ", " port))
+	 (writec port #\&)
+	 (c-variable (car vars) port)
+	 (for-each (lambda (var)
+		     (display ", &" port)
+		     (c-variable var port))
+		   (cdr vars))))
+  (writec port #\)))
+
+(define (c-system-call proc args port)
+  (display proc port)
+  (writec port '#\()
+  (if (not (null? args))
+      (let loop ((args args))
+        (c-value (car args) port)
+        (cond ((not (null? (cdr args)))
+               (writec port '#\,)
+               (writec port '#\space)
+               (loop (cdr args))))))
+  (writec port '#\))
+  (values))
+
+(define (indent-to port indent)
+  (if (> (current-column port) indent)
+      (newline port))
+  (do ((c (current-column port) (+ c 1)))
+      ((>= c indent))
+    (write-char #\space port)))
+
+
diff --git a/ps-compiler/prescheme/c-decl.scm b/ps-compiler/prescheme/c-decl.scm
new file mode 100644
index 0000000..3e13285
--- /dev/null
+++ b/ps-compiler/prescheme/c-decl.scm
@@ -0,0 +1,385 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+; C variable declarations.
+; 
+; (write-function-prototypes forms port)
+;
+; (write-variable-declarations vars port indent)
+
+; Writing declarations.
+
+(define (write-function-prototypes forms port)
+  (for-each (lambda (f)
+	      (if (eq? (form-type f) 'lambda)
+		  (if (form-tail-called? f)
+		      (write-function-tail-prototype (form-c-name f)
+						     (form-exported? f)
+						     port)
+		      (write-function-prototype (form-var f)
+						(form-c-name f)
+						(form-exported? f)
+						port))))
+	    forms))
+
+(define (write-function-tail-prototype name exported? port)
+  (if (not exported?)
+      (display "static " port))
+  (display "long T" port)
+  (display name port)
+  (display "(void);" port)
+  (newline port))
+
+(define (write-function-prototype var name exported? port)
+  (if (not exported?)
+      (display "static " port))
+  (receive (result args)
+      (parse-arrow-type (final-variable-type var))
+    (display-c-type result
+		    (lambda (port)
+		      (display name port))
+		    port)
+    (write-char #\( port)
+    (if (null? args)
+	(display "void" port)
+	(begin
+	  (display-c-type (car args) #f port)
+	  (let loop ((args (cdr args)))
+	    (if (not (null? args))
+		(begin
+		  (display ", " port)
+		  (display-c-type (car args) #f port)
+		  (loop (cdr args)))))))
+    (display ");" port)
+    (newline port)))
+
+; Write declarations for global variables.
+
+(define (write-global-variable-declarations forms port)
+  (for-each (lambda (form)
+	      (if (memq (form-type form)
+			'(stob initialize alias))
+		  (let* ((var (form-var form))
+			 (type (final-variable-type var)))
+		    (if (not (or (eq? type type/unit)
+				 (eq? type type/null)))
+			(really-write-variable-declaration
+			   var type (form-exported? form) port 0)))))
+	    forms))
+
+; Write general variable declarations.
+
+(define (write-variable-declarations vars port indent)
+  (for-each (lambda (var)
+	      (let ((type (final-variable-type var)))
+		(if (not (or (eq? type type/unit)
+			     (eq? type type/null)))
+		    (really-write-variable-declaration var type #t port indent))))
+	    vars))
+
+(define (really-write-variable-declaration var type exported? port indent)
+  (indent-to port indent)
+  (if (not exported?)
+      (display "static " port))
+  (display-c-type type
+		  (lambda (port)
+		    (c-variable-no-shadowing var port))
+		  port)
+  (writec port #\;))
+
+;----------------------------------------------------------------
+; Writing C types
+
+(define (display-c-type type name port)
+  (display-c-base-type (type->c-base-type type) port)
+  (if name (display " " port))
+  (display-c-type-modifiers type name port))
+
+(define (write-c-coercion type out)
+  (write-char #\( out)
+  (display-c-type type #f out)
+  (write-char #\) out))
+  
+; Searches through the type modifiers until the base type is found.
+; Unspecified result types are assumed to be `void'.
+
+(define (type->c-base-type type)
+  (let ((type (maybe-follow-uvar type)))
+    (cond ((or (base-type? type)
+	       (record-type? type))
+	   type)
+	  ((pointer-type? type)
+	   (type->c-base-type (pointer-type-to type)))
+	  ((arrow-type? type)
+	   (let ((res (arrow-type-result type)))
+ 	     (cond ((and (uvar? res)
+ 			 (not (uvar-binding res)))
+ 		    type/unit)
+ 	           ((not (tuple-type? res))
+		    (type->c-base-type res))
+		   ((null? (tuple-type-types res))
+		    type/unit)
+		   (else
+		    (type->c-base-type (car (tuple-type-types res)))))))
+	  (else
+	   (bug "don't know how to write ~S as a C type" type)))))
+
+; Table of C names for base types.
+
+(define c-decl-table (make-integer-table))
+
+(define (add-c-type-declaration! type decl)
+  (table-set! c-decl-table (base-type-uid type) decl))
+
+(for-each (lambda (p)
+	    (let ((type (lookup-type (car p))))
+	      (add-c-type-declaration! type (cadr p))))
+	  '((boolean "char")
+	    (char    "char")
+	    (integer "long")
+	    (address "char *")
+	    (input-port "FILE *")
+	    (output-port "FILE *")
+	    (unit    "void")
+	    (null    "void")))
+
+(define (display-c-base-type type port)
+  (cond ((record-type? type)
+	 (display "struct " port)
+	 (write-c-identifier (record-type-name type) port))
+	(else
+	 (display (or (table-ref c-decl-table (base-type-uid type))
+		      (bug "no C declaration for ~S" type))
+		  port))))
+
+; Writes out the modifiers of TYPE with NAME used when the base type is reached.
+
+(define (display-c-type-modifiers type name port)
+  (let label ((type type) (name name))
+    (let ((type (maybe-follow-uvar type)))
+      (cond ((or (base-type? type)
+		 (record-type? type))
+	     (if name (name port)))
+	    ((pointer-type? type)
+	     (label (pointer-type-to type)
+		    (lambda (port)
+		      (format port "*")
+		      (if name (name port)))))
+	    ((arrow-type? type)
+	     (format port "(*")
+	     (receive (return-type args)
+		 (parse-arrow-type type)
+	       (label return-type name)
+	       (format port ")(")
+	       (cond ((null? args)
+		      (display "void" port))
+		     (else
+		      (display-c-type (car args) #f port)
+		      (do ((args (cdr args) (cdr args)))
+			  ((null? args))
+			(display ", " port)
+			(display-c-type (car args) #f port))))
+	       (format port ")")))
+	    (else
+	     (bug "don't know how to write ~S as a C type" type))))))
+
+(define (parse-arrow-type type)
+  (receive (first rest)
+      (parse-return-type (arrow-type-result type))
+    (values first
+	    (append (arrow-type-args type)
+		    (map make-pointer-type rest)))))
+
+(define (parse-return-type type)
+  (cond ((not (tuple-type? type))
+	 (values (if (and (uvar? type)
+ 			  (not (uvar-binding type)))
+ 		     type/unit
+ 		     type)
+ 		 '()))
+	((null? (tuple-type-types type))
+	 (values type/unit '()))
+	(else
+	 (values (car (tuple-type-types type))
+		 (cdr (tuple-type-types type))))))
+
+;------------------------------------------------------------
+; Collecting local variables.  Each is added to this list when it is first
+; used.
+
+(define *local-vars* '())
+
+(define (declare-local-variables port)
+  (write-variable-declarations *local-vars* port 2))
+
+; Some primops must be given continuations so that calls to them will
+; be translated into separate C statements and so expand into arbitrarily
+; complex chunks of C if necessary.
+
+(define (fixup-nasty-c-primops! call)
+  (let ((top call))
+    (let label ((call call))
+      (cond ((call-node? call)
+	     (if (and (= 0 (call-exits call))
+		      (nasty-c-primop-call? call))
+		 (set! top (expand-nasty-c-primop! call top)))
+	     (walk-vector label (call-args call)))))
+    (do ((i 0 (+ i 1)))
+	((= i (call-arg-count top)))
+      (let ((arg (call-arg top i)))
+	(if (lambda-node? arg)
+	    (fixup-nasty-c-primops! (lambda-body arg)))))))
+
+(define (nasty-c-primop-call? call)
+  (case (primop-id (call-primop call))
+    ((lshl ashl ashr)     ; C does poorly when shifting by large amounts
+     (not (literal-node? (call-arg call 1))))
+    (else #f)))
+
+; Give CALL a continuation and move it above TOP, replacing CALL
+; with the continuation's variable.
+;
+; top = (p1 ... (p2 a1 ...) ...)
+;  =>
+; (p2 (lambda (v) (p1 ... v ...)) a1 ...)
+
+(define (expand-nasty-c-primop! call top)
+  (let* ((var (make-variable 'x (node-type call)))
+	 (cont (make-lambda-node 'c 'cont (list var))))
+    (move call
+	  (lambda (call)
+	    (make-reference-node var)))
+    (insert-body call
+		 cont
+		 (node-parent top))
+    (set-call-exits! call 1)
+    (insert-call-arg call 0 cont)
+    call))
+
+;------------------------------------------------------------
+; Declare the variables used to pass arguments to procedures.
+; This is done in each procedure so that the C compiler doesn't have to contend
+; with the possibility of globally visible side-effects.
+
+(define (write-arg-variable-declarations lambdas merged port)
+  (let ((lambdas (filter (lambda (l)
+			   (eq? 'jump (lambda-type l)))
+			 lambdas))
+	(merged (map form-value merged)))
+    (really-write-arg-variable-declarations lambdas "arg" port 2)
+    (really-write-arg-variable-declarations merged "merged_arg" port 2)))
+
+(define (write-global-arg-variable-declarations forms port)
+  (let ((lambdas (filter-map (lambda (f)
+			       (if (and (form-var f)
+					(memq? 'tail-called
+					       (variable-flags (form-var f))))
+				   (form-value f)
+				   #f))
+			     forms)))
+    (really-write-arg-variable-declarations lambdas "goto_arg" port 0)))
+  
+(define (really-write-arg-variable-declarations lambdas name port indent)
+  (for-each (lambda (data)
+	      (destructure (((uid type . indicies) data))
+		(if (not (eq? type type/unit))
+		    (for-each (lambda (i)
+				(indent-to port indent)
+				(declare-arg-variable type uid i name port))
+			      indicies))))
+	    (get-variable-decl-data lambdas)))
+
+(define (get-variable-decl-data lambdas)
+  (let ((data '()))
+    (for-each (lambda (l)
+		(do ((vars (if (eq? 'jump (lambda-type l))
+			       (lambda-variables l)
+			       (cdr (lambda-variables l)))
+			   (cdr vars))
+		     (i 0 (+ i 1)))
+		    ((null? vars))
+		  (let* ((type (final-variable-type (car vars)))
+			 (uid (type->uid type))
+			 (datum (assq uid data)))
+		    (cond ((not datum)
+			   (set! data (cons (list uid type i) data)))
+			  ((not (memq i (cddr datum)))
+			   (set-cdr! (cdr datum) (cons i (cddr datum))))))))
+	      lambdas)
+    data))
+
+(define (declare-arg-variable type uid i name port)
+  (display-c-type type
+		  (lambda (port)
+		    (format port "~A~DK~D" name uid i))
+		  port)
+  (format port ";~%"))
+
+;------------------------------------------------------------
+
+(define (write-argument-initializers arg-vars port indent)
+  (really-write-argument-initializers arg-vars "arg" #f port indent))
+
+(define (write-merged-argument-initializers arg-vars port indent)
+  (really-write-argument-initializers arg-vars "merged_arg" #f port indent))
+
+(define (write-global-argument-initializers arg-vars port indent)
+  (really-write-argument-initializers arg-vars "goto_arg" #t port indent))
+
+(define (really-write-argument-initializers arg-vars name type? port indent)
+  (do ((i 0 (+ i 1))
+       (vars arg-vars (cdr vars)))
+      ((null? vars) (values))
+    (if (used? (car vars))
+	(let* ((var (car vars))
+	       (type (final-variable-type var)))
+	  (cond ((not (eq? type/unit type))
+		 (indent-to port indent)
+		 (if type?
+		     (display-c-type type
+				     (lambda (port) (c-variable var port))
+				     port)
+		     (c-variable var port))
+		 (display " = " port)
+		 (display (c-argument-var name type i port) port)
+		 (write-char '#\; port)))))))
+
+(define (c-argument-var name type i port)
+  (format #f "~A~DK~D" name (type->uid type) i))
+
+(define *type-uids* '())
+(define *next-type-uid* 0)
+
+(define (type->uid type)
+  (cond ((any (lambda (p)
+		(type-eq? type (car p)))
+	      *type-uids*)
+	 => cdr)
+	(else
+	 (let ((id *next-type-uid*))
+	   (set! *next-type-uid* (+ id 1))
+	   (set! *type-uids* (cons (cons type id) *type-uids*))
+	   id))))
+
+;----------------------------------------------------------------
+; Random utility here for historical reasons.
+
+(define (goto-call? call)
+  (and (calls-this-primop? call 'unknown-tail-call)
+       (goto-protocol? (literal-value (call-arg call 2)))))
+
+;----------------------------------------------------------------
+; random type stuff
+
+(define (reference-type node)
+  (finalize-variable-type (reference-variable node)))
+
+(define (finalize-variable-type var)
+  (let* ((type (finalize-type (variable-type var)))
+	 (type (if (uvar? type)
+		   type/null
+		   type)))
+    (set-variable-type! var type)
+    type))
+
+(define final-variable-type finalize-variable-type)
+
diff --git a/ps-compiler/prescheme/c-stuff b/ps-compiler/prescheme/c-stuff
new file mode 100644
index 0000000..71b83d1
--- /dev/null
+++ b/ps-compiler/prescheme/c-stuff
@@ -0,0 +1,131 @@
+Put the case defn and the system-status enumeration in a file and load
+it into the base package.
+
+Have system status be a enumeration macro that doesn't give numbers
+but instead calls to (named-c-constant "FOO") with the obvious translation.
+Need a normal enumerated definition for running with Scheme.
+Of course, if there is no overlap we can just use negative numbers for
+the error numbers visible in Pre-Scheme.
+
+  PS_READ_CHAR(port_10X, Kchar_27X, eofP_15X, status_16X)
+
+
+#define PS_PEEK_CHAR(PORT,RESULT,EOFP,STATUS)
+{
+  FILE * TTport = PORT;
+  
+  if (EOF == (RESULT = getc(TTport)))
+    RESULT = ps_read_char(TTport, &EOFP, &STATUS);
+  else {
+    EOFP = 0;
+    STATUS = 0; }
+}
+
+#define PS_GETC(PORT,RESULT)      /* RESULT = getc(PORT); */ \
+
+{                                          \
+  FILE * TTport = PORT;			   \
+  int errorp;				   \
+  while (EOF == (RESULT = getc(TTport))	   \
+	 && (errorp = ferror(TTport),	   \
+	     clearerr(TTport),		   \
+	     (errorp && errno == EINTR)))  \
+    ;					   \
+}
+
+char
+ps_read_char( FILE *filep, int *eofp )
+{
+  int value;
+
+  while (TRUE) {
+    value = getc(filep);
+    if (EOF != value) {
+      *eofp = FALSE;
+      return value; }
+    if (ferror(filep)) {
+      clearerr(filep);
+      if (errno != EINTR) {
+        ps_status_errno = errno;
+	*eofp = FALSE;
+        return 0; } }
+    else {
+      *eofp = TRUE;
+      return 0; }}
+}
+ 
+/* Identical to ps_read_char except that we give the character back. */
+
+char
+ps_peek_char( FILE *filep )
+{
+  int value;
+
+  while (TRUE) {
+    value = getc(filep);
+    if (EOF != value) {
+      ungetc(value);
+      return value;
+    }
+    if (ferror(filep)) {
+      clearerr(filep);
+      if (errno != EINTR) {
+        ps_status_errno = errno;
+        return 0;
+      }
+    }
+    else {
+      ps_status_errno = EOF_ERRNO;
+      return 0;
+    }
+  }
+}
+
+void
+ps_write_char( char c; FILE *filep )
+{
+  while (TRUE) {
+    if (EOF != putc(c, filep);
+      return;
+    if (ferror(filep)) {
+      clearerr(filep);
+      if (errno != EINTR) {
+        ps_status_errno = errno;
+        return;
+      }
+    }
+    else {
+      ps_status_errno = EOF_ERRNO;
+      return;
+    }
+  }
+}
+ 
+ 
+; no status
+current-input-port current-output-port current-error-port
+
+; -> port status
+open-input-file open-output-file
+
+; -> status
+close-output-port close-input-port
+
+; -> value eof? status
+read-char peek-char read-integer
+
+; -> status
+write-char newline write-string write-integer force-output
+
+
+Error status:
+
+   no-errors         0
+   parse-error       EINVAL   invalid argument
+   pending-i/o       EAGAIN?  resource temporarily unavailable
+   file-not-found    ENOENT   no such
+                     EISDIR   is a directory
+   out-of-memory     ENOMEM   not enough space
+   out-of-channels   EMFILE   too many open files
+   channel-closed    EBADF    bad file descriptor
+   no-such-channel   EBADF    bad file descriptor
diff --git a/ps-compiler/prescheme/c.scm b/ps-compiler/prescheme/c.scm
new file mode 100644
index 0000000..ed07a4a
--- /dev/null
+++ b/ps-compiler/prescheme/c.scm
@@ -0,0 +1,467 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+; Translating the node tree into C
+
+(define (write-c-file init-name file header forms)
+  (set! *c-variable-id* 0)
+  (set! *type-uids* '())
+  (set! *next-type-uid* 0)
+  (let* ((real-out (open-output-file file))
+	 (out (make-tracking-output-port real-out)))
+    (merge-forms forms)
+    (check-hoisting forms)
+    (format #t "Translating~%")
+    (write-c-header header out)
+    (write-function-prototypes forms out)
+    (write-global-arg-variable-declarations forms out)
+    (write-global-variable-declarations forms out)
+    (newline out)
+    (for-each (lambda (f)
+		(case (form-type f)
+		  ((lambda)
+		   (compile-proc-to-c f out))
+		  ((alias constant integrate merged stob initialize unused)
+		   (values))
+		  (else
+		   (bug "unknown type of form ~S" f))))
+	      forms)
+    (write-c-main init-name out forms)
+    (newline out)
+    (set! *type-uids* '())
+    (close-output-port out)
+    (close-output-port real-out)))
+    
+
+(define (write-c-main init-name out forms)
+  (set! *doing-tail-called-procedure?* #f)
+  (set! *current-merged-procedure* #f)
+  (cond ((any? (lambda (f)
+		 (or (eq? (form-type f) 'initialize)
+		     (eq? (form-type f) 'stob)
+		     (eq? (form-type f) 'alias)))
+	       forms)
+	 (write-c-main-header (if init-name init-name 'main) out)
+	 (for-each (lambda (f)
+		     (case (form-type f)
+		       ((initialize alias)
+			(write-initialize (form-var f) (form-value f) out))
+		       ((stob)
+			(write-stob (form-var f)
+				    (form-value-type f)
+				    (lambda-body (form-value f))
+				    out))))
+		   forms)
+	 (write-c-main-end out))))
+
+(define (write-c-header header out)
+  (format out "#include <stdio.h>~%")
+  (format out "#include \"prescheme.h\"~%")
+  (for-each (lambda (s)
+	      (display s out)
+	      (newline out))
+	    header)
+  (for-each (lambda (rtype)
+	      (declare-record-type rtype out))
+	    (all-record-types))
+  (newline out)
+  (values))
+
+(define (declare-record-type rtype out)
+  (format out "~%struct ")
+  (write-c-identifier (record-type-name rtype) out)
+  (format out " {~%")
+  (for-each (lambda (field)
+	      (format out "  ")
+	      (display-c-type (record-field-type field)
+			      (lambda (port)
+				(write-c-identifier (record-field-name field)
+						    out))
+			      out)
+	      (format out ";~%"))
+	    (record-type-fields rtype))
+  (format out "};"))
+
+; Even when finished we need to keep the lambda around for help with
+; calls to it.
+
+(define (compile-proc-to-c form out)
+  (format #t " ~A~%" (form-c-name form))
+  (let ((name (form-c-name form)))
+    (proc->c name form (form-shadowed form) out #f)
+    (for-each make-form-unused! (form-merged form))
+    (erase (detach-body (lambda-body (form-value form))))
+    (suspend-form-use! form)))
+
+(define (form-c-name form)
+  (let* ((var (form-var form))
+	 (name (c-ify (variable-name var))))
+    (if (generated-top-variable? var)
+	(string-append "H" name (number->string (c-variable-id var)))
+	name)))
+
+(define (no-value-node? node)
+  (or (undefined-value-node? node)
+      (and (reference-node? node)
+	   (let ((type (final-variable-type (reference-variable node))))
+	     (or (eq? type type/unit)
+		 (eq? type type/null))))))
+
+;------------------------------------------------------------
+; Initialization procedure at the end of the file (often called `main').
+
+; Header for initialization code
+
+(define (write-c-main-header initname out)
+  (format out "void~%")
+  (write-c-identifier initname out)
+  (format out "(void)~%{"))
+
+; Write the end of the initialization code
+
+(define (write-c-main-end out)
+  (format out "~&}"))
+
+(define (write-initialize var value out)
+  (let ((wants (maybe-follow-uvar (variable-type var))))
+    (receive (value has)
+	(cond ((variable? value)
+	       (values value (final-variable-type value)))
+	      ((literal-node? value)
+	       (values (literal-value value) (literal-type value)))
+	      ((reference-node? value)
+	       (let ((var (reference-variable value)))
+		 (values var (final-variable-type var))))
+	      (else
+	       (error "unknown kind of initial value ~S" value)))
+      (cond ((not (unspecific? value))
+	     (c-assign-to-variable var out 0)
+	     (if (not (type-eq? wants has))
+		 (write-c-coercion wants out))
+	     (cond ((input-port? value)
+		    (display "0" out))
+		   ((output-port? value)
+		    (display "1" out))
+		   ((variable? value)
+		    (c-variable value out))
+		   (else
+		    (c-literal-value value has out)))
+	     (writec out '#\;))))))
+
+(define (write-stob var type call out)
+  (let ((value (literal-value (call-arg call 0)))
+	(wants (final-variable-type var)))
+    (c-assign-to-variable var out 0)
+    (cond ((vector? value)
+	   (if (not (type-eq? type wants))
+	       (write-c-coercion wants out))
+	   (format out "malloc(~D * sizeof(" (vector-length value))
+	   (display-c-type (pointer-type-to type) #f out)
+	   (format out "));")
+	   (do ((i 0 (+ i 1)))
+	       ((>= i (vector-length value)))
+	     (let* ((elt (call-arg call (+ i 1)))
+		    (has (finalize-type
+			  (if (reference-node? elt)
+			      (variable-type (reference-variable elt))
+			      (literal-value-type (literal-value elt))))))
+	       (newline out)
+	       (c-variable var out)
+	       (format out "[~D] = " i)
+	       (if (not (type-eq? (pointer-type-to type) has))
+		   (write-c-coercion (pointer-type-to type) out))
+	       (c-value elt out)
+	       (write-char #\; out))))
+	  (else
+	   (error "don't know how to generate stob value ~S" value)))))
+
+;------------------------------------------------------------
+; Writing out a procedure.
+
+(define (proc->c name form rename-vars port maybe-merged-count)
+  (let ((top       (form-value form))
+	(merged    (form-merged form))
+	(tail?     (form-tail-called? form))
+	(exported? (form-exported? form))
+	(lambda-kids lambda-block))        ; filled in by the hoist code
+    (let ((lambdas (filter (lambda (l)
+			     (not (proc-lambda? l)))
+			   (lambda-kids top))))
+      (if maybe-merged-count
+	  (merged-proc->c name top lambdas merged maybe-merged-count port tail?)
+	  (real-proc->c name (form-var form) top lambdas
+			merged rename-vars port tail? exported?))
+      (values))))
+
+(define (write-merged-form form port)
+  (format #t "  ~A~%" (form-c-name form))
+  (proc->c (form-c-name form)
+	   form
+	   '()
+	   port
+	   (length (variable-refs (form-var form)))))
+
+;------------------------------------------------------------
+
+; 1. write the header
+; 2. declare the local variables
+; 3. write out the body
+; 4. write out all of the label lambdas
+
+(define (real-proc->c id var top lambdas merged rename-vars port tail? exported?)
+  (let ((vars (cdr (lambda-variables top)))
+	(return-type (final-variable-type (car (lambda-variables top))))
+	(all-lambdas (append lambdas (gather-merged-lambdas merged)))
+	(merged-procs (gather-merged-procs merged)))
+    (set! *doing-tail-called-procedure?* tail?)
+    (set! *current-merged-procedure* #f)
+    (receive (first rest)
+	(parse-return-type return-type)
+      (set! *extra-tail-call-args*
+	    (do ((i (length rest) (- i 1))
+		 (args '() (cons (format #f "TT~D" (- i 1)) args)))
+		((= i 0)
+		 args))))
+    (set! *jumps-to-do* '())
+    (write-procedure-header id return-type vars port tail? exported?)
+    (write-char '#\{ port)
+    (newline port)
+    (for-each (lambda (v)
+		(set-variable-flags! v (cons 'shadowed (variable-flags v))))
+	      rename-vars)
+    (write-arg-variable-declarations all-lambdas merged port)      
+    (write-rename-variable-declarations rename-vars port)
+    (write-merged-declarations merged port)
+    (fixup-nasty-c-primops! (lambda-body top))
+    (for-each (lambda (form)
+		(write-merged-decls form port))
+	      merged)
+    (clear-lambda-generated?-flags lambdas)
+    (set! *local-vars* '())
+    (let ((body (call-with-string-output-port
+		 (lambda (temp-port)
+		   (let ((temp-port (make-tracking-output-port temp-port)))
+		     (write-c-block (lambda-body top) temp-port 2)
+		     (write-jump-lambdas temp-port 0)
+		     (for-each (lambda (f)
+				 (write-merged-form f temp-port))
+			       (reverse merged))  ; makes for more readable output
+		     (newline temp-port)
+		     (force-output temp-port))))))
+      (declare-local-variables port)
+      (if tail? 
+	  (write-global-argument-initializers (cdr (lambda-variables top))
+					      port 2))
+      (format port "~% {")
+      (display body port)
+      (write-char '#\} port))
+    (for-each (lambda (v)
+		(set-variable-flags! v (delq! 'shadowed (variable-flags v))))
+	      rename-vars)
+    (values)))
+
+; These global variables should be replaced with fluids.
+
+(define *doing-tail-called-procedure?* #f)
+(define *current-merged-procedure* #f)
+(define *extra-tail-call-args* '())
+
+(define (gather-merged-lambdas merged)
+  (let loop ((merged merged) (lambdas '()))
+    (if (null? merged)
+	lambdas
+	(loop (append (form-merged (car merged)) (cdr merged))
+	      (append (form-lambdas (car merged)) lambdas)))))
+
+(define (gather-merged-procs merged)
+  (let loop ((merged merged) (procs '()))
+    (if (null? merged)
+	procs
+	(loop (append (form-merged (car merged)) (cdr merged))
+	      (cons (form-value (car merged)) procs)))))
+
+(define (write-merged-decls form port)
+  (let ((top (form-value form))
+	(merged (form-merged form)))
+    (let ((vars (filter (lambda (var)
+			  (and (used? var)
+			       (not (eq? type/unit (final-variable-type var)))))
+			(cdr (lambda-variables top)))))
+      (write-variable-declarations vars port 2))
+    (write-merged-declarations merged port)))
+
+(define (merged-proc->c name top lambdas merged return-count port tail?)
+  (let ((vars (cdr (lambda-variables top)))
+	(body (lambda-body top)))
+    (set! *doing-tail-called-procedure?* tail?)
+    (set! *current-merged-procedure* name)
+    (write-merged-header name top port)
+    (write-char '#\{ port)
+    (clear-lambda-generated?-flags lambdas)
+    (write-c-block body port 2)
+    (write-jump-lambdas port 0)
+    (if (not tail?)
+	(write-merged-return name return-count port))
+    (for-each (lambda (f)
+		(write-merged-form f port))
+	      (reverse merged))  ; makes for more readable output
+    (write-char '#\} port)
+    (newline port)
+    (values)))
+
+(define (write-merged-header name top port)
+  (format port "~% ~A: {~%" name)
+  (if (not (null? (cdr (lambda-variables top))))
+      (write-merged-argument-initializers (cdr (lambda-variables top)) port 2)))
+
+; We use `default:' for the last tag so that the C compiler will
+; know that the code following the switch is unreachable (to avoid
+; a spurious warning if this is the end of the procedure).
+
+(define (write-merged-return name return-count port)
+  (format port "~% ~A_return:~%  switch (~A_return_tag) {~%" name name)
+  (do ((i 0 (+ i 1)))
+      ((>= i (- return-count 1)))
+    (format port "  case ~S: goto ~A_return_~S;~%" i name i))
+  (format port "  default: goto ~A_return_~S;~%" name (- return-count 1))
+  (format port "  }"))
+
+(define (write-merged-declarations forms port)
+  (for-each (lambda (f)
+	      (if (not (form-tail-called? f))
+		  (write-merged-declaration f port)))
+	    forms))
+
+(define (write-merged-declaration form port)
+  (let ((name (form-c-name form))
+	(types (lambda-return-types (form-value form))))
+    (format port "~%  int ~A_return_tag;" name)
+    (do ((i 0 (+ i 1))
+	 (types types (cdr types)))
+	((null? types))
+      (let ((type (car types)))
+	(cond ((not (or (eq? type type/unit)
+			(eq? type type/null)))
+	       (format port "~%  ")
+	       (display-c-type type
+			       (lambda (port)
+				 (format port "~A~D_return_value" name i))
+			       port)
+	       (writec port #\;)))))))
+
+(define (lambda-return-types node)
+  (let ((type (final-variable-type (car (lambda-variables node)))))
+    (if (tuple-type? type)
+	(tuple-type-types type)
+	(list type))))
+
+(define (write-procedure-header id return-type vars port tail? exported?)
+  (newline port)
+  (if (not exported?)
+      (display "static " port))
+  (receive (first rest)
+      (parse-return-type return-type)
+    (display-c-type (if tail? type/integer first)
+		    (lambda (port)
+		      (if tail? (write-char #\T port))
+		      (display id port))
+		    port)
+    (write-char '#\( port)
+    (if (not tail?)
+	(let ((args (append vars
+			    (do ((i 0 (+ i 1))
+				 (rest rest (cdr rest))
+				 (res '() (cons (cons i (car rest)) res)))
+				((null? rest)
+				 (reverse res))))))
+	  (if (null? args)
+	      (display "void" port)
+	      (write-variables args port))))
+    (write-char '#\) port)
+    (newline port)))
+
+; Write the names of VARS out to the port.  VARS may contain pairs of the
+; form (<integer> . <type>) as well as variables.
+
+(define (write-variables vars port)
+  (let ((do-one (lambda (var)
+		  (display-c-type (if (pair? var)
+				      (make-pointer-type (cdr var))
+				      (final-variable-type var))
+				  (lambda (port)
+				    (if (pair? var)
+					(format port "TT~D" (car var))
+					(c-variable var port)))
+				  port))))
+    (cond ((null? vars)
+	   (values))
+	  ((null? (cdr vars))
+	   (do-one (car vars)))
+	  (else
+	   (do-one (car vars))
+	   (do ((vars (cdr vars) (cdr vars)))
+	       ((null? vars)
+		(values))
+	     (write-char '#\, port)
+	     (write-char '#\space port)
+	     (do-one (car vars)))))))
+  
+(define (write-rename-variable-declarations vars port)
+  (for-each (lambda (var)
+	      (indent-to port 2)
+	      (display-c-type (final-variable-type var)
+			      (lambda (port)
+				(writec port #\R)
+				(write-c-identifier (variable-name var) port))
+			      port)
+	      (display " = " port)
+	      (write-c-identifier (variable-name var) port)
+	      (format port ";~%"))
+	    vars))
+
+(define (write-c-block body port indent)
+  (write-c-block-with-args body '() port indent))
+
+(define (write-c-block-with-args body arg-vars port indent)
+  (if (not (null? arg-vars))
+      (write-argument-initializers arg-vars port indent))
+  (call->c body port indent)
+  (write-char '#\} port))
+
+; Jump lambdas.  These are generated more-or-less in the order they are
+; referenced.
+
+(define (clear-lambda-generated?-flags lambdas)
+  (for-each (lambda (l)
+	      (set-lambda-block! l #f))
+	    lambdas))
+
+(define *jumps-to-do* '())
+
+(define (note-jump-generated! proc)
+  (if (not (lambda-block proc))
+      (begin
+	(set! *jumps-to-do* (cons proc *jumps-to-do*))
+	(set-lambda-block! proc #t))))
+
+(define (write-jump-lambdas port indent)
+  (let loop ()
+    (let ((jumps (reverse *jumps-to-do*)))
+      (set! *jumps-to-do* '())
+      (for-each (lambda (jump)
+		  (jump-lambda->c jump port indent))
+		jumps)
+      (if (not (null? *jumps-to-do*))
+	  (loop)))))
+      
+(define (jump-lambda->c node port indent)
+  (newline port)
+  (indent-to port indent)
+  (display " L" port)
+  (display (lambda-id node) port)
+  (display ": {" port)
+  (newline port)
+  (write-c-block-with-args (lambda-body node)
+			   (lambda-variables node)
+			   port
+			   (+ '2 indent)))
+
diff --git a/ps-compiler/prescheme/display.scm b/ps-compiler/prescheme/display.scm
new file mode 100644
index 0000000..677a63b
--- /dev/null
+++ b/ps-compiler/prescheme/display.scm
@@ -0,0 +1,224 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+; Data must be done last as it may contain references to the other stuff.
+
+(define (display-forms-as-scheme forms out)
+  (receive (data other)
+      (partition-list (lambda (f)
+			(and (node? (form-value f))
+			     (literal-node? (form-value f))))
+		      forms)
+    (for-each (lambda (f)
+		(display-form-as-scheme f (schemify (form-value f)) out))
+	      other)
+    (for-each (lambda (f)
+		(display-data-form-as-scheme f out))
+	      data)))
+
+(define form-value (structure-ref forms form-value))
+(define form-var   (structure-ref forms form-var))
+
+(define literal-node? (node-predicate 'literal #f))
+
+(define (display-form-as-scheme f value out)
+  (cond ((unspecific? value)
+	 (p `(define ,(get-form-name f)) out)
+	 (newline out))
+	((or (external-value? value)
+	     (memq 'closed-compiled-primitive (variable-flags (form-var f))))
+	 (values))
+	(else
+	 (p `(define ,(get-form-name f) ,value)
+	    out)
+	 (newline out))))
+
+(define (display-data-form-as-scheme f out)
+  (let* ((value (clean-literal (node-form (form-value f))))
+	 (value (if (and (quoted? value)
+			 (not (or (list? (cadr value))
+				  (vector? (cadr value)))))
+		    (cadr value)
+		    value)))
+    (display-form-as-scheme f value out)))
+
+(define (get-form-name form)
+  (name->symbol (get-variable-name (form-var form))))
+
+(define (schemify node)
+  (if (node? node)
+      ((operator-table-ref schemifiers (node-operator-id node))
+       node)
+      (schemify-sexp node)))
+
+(define unspecific?
+  (let ((x (if #f #t)))
+    (lambda (y)
+      (eq? x y))))
+
+(define schemifiers
+  (make-operator-table (lambda (node)
+			 (let ((form (node-form node)))
+			   (if (list? form)
+			       (map schemify form)
+			       form)))))
+
+(define (define-schemifier name type proc)
+  (operator-define! schemifiers name type proc))
+
+(define-schemifier 'name 'leaf
+  (lambda (node)
+    (cond ((node-ref node 'binding)
+	   => (lambda (binding)
+		(let ((var (binding-place binding)))
+		  (if (variable? var)
+		      (get-variable-name var)
+		      (desyntaxify (node-form node))))))
+	  (else
+	   (name->symbol (node-form node))))))
+
+; Rename things that have differ in Scheme and Pre-Scheme
+
+(define aliases
+  (map (lambda (s)
+	 (cons s (string->symbol (string-append "ps-" (symbol->string s)))))
+       '(read-char peek-char write-char newline
+	 open-input-file open-output-file
+	 close-input-port close-output-port)))
+
+(define (get-variable-name var)
+  (cond ((and (generated-top-variable? var)
+	      (not (memq 'closed-compiled-primitive (variable-flags var))))
+	 (string->symbol (string-append (symbol->string
+					 (name->symbol (variable-name var)))
+					"."
+					(number->string (variable-id var)))))
+	((assq (variable-name var) aliases)
+	 => cdr)
+	(else
+	 (variable-name var))))
+
+(define (name->symbol name)
+  (if (symbol? name)
+      name
+      (string->symbol (string-append (symbol->string (generated-symbol name))
+				     "."
+				     (number->string (generated-uid name))))))
+
+(define-schemifier 'quote #f
+  (lambda (node)
+    (list 'quote (cadr (node-form node)))))
+
+(define-schemifier 'literal #f
+  (lambda (node)
+    (let ((form (node-form node)))
+      (cond ((primop? form)
+	     (primop-id form))
+	    ((external-value? form)
+	     (let ((string (external-value-string form)))
+	       (if (string=? string "(long(*)())")
+		   'integer->procedure
+		   (string->symbol (external-value-string form)))))
+	    ((external-constant? form)
+	     `(enum ,(external-constant-enum-name form)
+		    ,(external-constant-name form)))
+	    (else
+	     (schemify-sexp form))))))
+
+(define-schemifier 'unspecific #f
+  (lambda (node)
+    ''unspecific))
+
+; Used for primitives in non-call position.  The CDR of the form is a
+; variable that will be bound to the primitive's closed-compiled value.
+
+(define-schemifier 'primitive #f
+  (lambda (node)
+    (let ((form (node-form node)))
+      (cond ((pair? form)
+	     (get-variable-name (cdr form))) ; non-call position
+	    ((assq (primitive-id form) aliases)
+	     => cdr)
+	    (else
+	     (primitive-id form))))))
+
+; lambda, let-syntax, letrec-syntax...
+
+(define-schemifier 'letrec #f
+  (lambda (node)
+    (let ((form (node-form node)))
+      `(letrec ,(map (lambda (spec)
+                       `(,(schemify (car spec)) ,(schemify (cadr spec))))
+                     (cadr form))
+         ,@(map (lambda (f) (schemify f))
+                (cddr form))))))
+
+(define-schemifier 'lambda #f
+  (lambda (node)
+    (let ((form (node-form node)))
+      `(lambda ,(let label ((vars (cadr form)))
+		  (cond ((pair? vars)
+			 (cons (schemify (car vars))
+			       (label (cdr vars))))
+			((null? vars)
+			 '())
+			(else
+			 (schemify vars))))
+	 ,@(map schemify (cddr form))))))
+
+(define-schemifier 'goto #f
+  (lambda (node)
+    (map schemify (cdr (node-form node)))))
+
+(define (schemify-sexp thing)
+  (cond ((name? thing)
+	 (desyntaxify thing))
+	((primop? thing)
+	 (primop-id thing))
+	((primitive? thing)
+	 (primitive-id thing))
+	((variable? thing)
+	 (get-variable-name thing))
+	((pair? thing)
+	 (let ((x (schemify-sexp (car thing)))
+	       (y (schemify-sexp (cdr thing))))
+	   (if (and (eq? x (car thing))
+		    (eq? y (cdr thing)))
+	       thing			;+++
+	       (cons x y))))
+	((vector? thing)
+	 (let ((new (make-vector (vector-length thing) #f)))
+	   (let loop ((i 0) (same? #t))
+	     (if (>= i (vector-length thing))
+		 (if same? thing new)	;+++
+		 (let ((x (schemify-sexp (vector-ref thing i))))
+		   (vector-set! new i x)
+		   (loop (+ i 1)
+			 (and same? (eq? x (vector-ref thing i)))))))))
+	(else thing)))
+
+(define (clean-literal thing)
+  (cond ((name? thing)
+	 (desyntaxify thing))
+	((variable? thing)
+	 (get-variable-name thing))
+	((external-constant? thing)
+	 `(enum ,(external-constant-enum-name thing)
+		,(external-constant-name thing)))
+	((pair? thing)
+	 (let ((x (clean-literal (car thing)))
+	       (y (clean-literal (cdr thing))))
+	   (if (and (quoted? x) (quoted? y))
+	       `(quote (,(cadr x) . ,(cadr y)))
+	       `(cons ,x ,y))))
+	((vector? thing)
+	 (let ((elts (map clean-literal (vector->list thing))))
+	   (if (every? quoted? elts)
+	       `(quote ,(list->vector (map cadr elts)))
+	       `(vector . ,elts))))
+	(else
+	 `(quote ,thing))))
+
+(define (quoted? x)
+  (and (pair? x)
+       (eq? (car x) 'quote)))
\ No newline at end of file
diff --git a/ps-compiler/prescheme/eval.scm b/ps-compiler/prescheme/eval.scm
new file mode 100644
index 0000000..db0a79d
--- /dev/null
+++ b/ps-compiler/prescheme/eval.scm
@@ -0,0 +1,214 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+; Evaluator for nodes.
+
+; This doesn't handle n-ary procedures.
+
+; (NAME-NODE-BINDING name-node) is used as an EQ? key in local environments,
+; and passed as-is to the global-environment arguments.
+
+; Exports:
+; (EVAL-NODE node global-ref global-set! eval-primitive)
+; CLOSURE? (CLOSURE-NODE closure) (CLOSURE-ENV closure)
+; (UNSPECIFIC? thing)
+
+(define (eval-node node global-ref global-set! eval-primitive)
+  (eval node (make-env '()
+		       (make-eval-data global-ref
+				       global-set!
+				       eval-primitive))))
+
+(define-record-type eval-data :eval-data
+  (make-eval-data global-ref global-set! eval-primitive)
+  eval-data?
+  (global-ref     eval-data-global-ref)
+  (global-set!    eval-data-global-set!)
+  (eval-primitive eval-data-eval-primitive))
+
+; Environments
+
+(define-record-type env :env
+  (make-env alist eval-data)
+  env?
+  (alist env-alist)
+  (eval-data env-eval-data))
+
+(define (env-ref env name-node)
+  (let ((cell (assq name-node (env-alist env))))
+    (if cell
+	(cdr cell)
+	((eval-data-global-ref (env-eval-data env)) name-node))))
+
+(define (env-set! env name-node value)
+  (let ((cell (assq name-node (env-alist env))))
+    (if cell
+	(set-cdr! cell value)
+	((eval-data-global-set! (env-eval-data env))
+	 name-node
+	 value))))
+
+(define (extend-env env ids vals)
+  (make-env (append (map cons ids vals)
+		    (env-alist env))
+	    (env-eval-data env)))
+
+(define (eval-primitive primitive args env)
+  ((eval-data-eval-primitive (env-eval-data env)) primitive args))
+
+; Closures
+
+(define-record-type closure :closure
+  (make-closure node env)
+  closure?
+  (node closure-node)
+  (env real-closure-env)
+  (temp closure-temp set-closure-temp!))
+
+(define (closure-env closure)                   ; exported
+  (env-alist (real-closure-env closure)))
+
+(define (make-top-level-closure exp)
+  (make-closure exp the-empty-env))
+
+(define the-empty-env (make-env '() #f))
+
+; Main dispatch
+
+(define (eval node env)
+  ((operator-table-ref evaluators (node-operator-id node))
+   node
+   env))
+
+; Particular operators
+
+(define evaluators
+  (make-operator-table
+   (lambda (node env)
+     (error "no evaluator for node ~S" node))))
+
+(define (define-evaluator name proc)
+  (operator-define! evaluators name #f proc))
+
+(define (eval-list nodes env)
+  (map (lambda (node)
+	 (eval node env))
+       nodes))
+
+(define-evaluator 'literal
+  (lambda (node env)
+    (node-form node)))
+
+(define-evaluator 'unspecific
+  (lambda (node env)
+    (unspecific)))
+
+(define-evaluator 'unassigned
+  (lambda (node env)
+    (unspecific)))
+
+(define-evaluator 'real-external
+  (lambda (node env)
+    (let* ((exp (node-form node))
+	   (type (expand-type-spec (cadr (node-form (caddr exp))))))
+      (make-external-value (node-form (cadr exp))
+			   type))))
+
+(define-evaluator 'quote
+  (lambda (node env)
+    (cadr (node-form node))))
+
+(define-evaluator 'lambda
+  (lambda (node env)
+    (make-closure node env)))
+
+(define (apply-closure closure args)
+  (let ((node (closure-node closure))
+	(env (real-closure-env closure)))
+    (eval (caddr (node-form node))
+	  (extend-env env (cadr (node-form node)) args))))
+
+(define-evaluator 'name
+  (lambda (node env)
+    (env-ref env node)))
+
+(define-evaluator 'set!
+  (lambda (node env)
+    (let ((exp (node-form node)))
+      (env-set! env (cadr exp) (eval (caddr exp) env))
+      (unspecific))))
+
+(define-evaluator 'call
+  (lambda (node env)
+    (eval-call (car (node-form node))
+	       (cdr (node-form node))
+	       env)))
+
+(define-evaluator 'goto
+  (lambda (node env)
+    (eval-call (cadr (node-form node))
+	       (cddr (node-form node))
+	       env)))
+
+(define (eval-call proc args env)
+  (let ((proc (eval proc env))
+	(args (eval-list args env)))
+    (if (closure? proc)
+	(apply-closure proc args)
+	(eval-primitive proc args env))))
+
+(define-evaluator 'begin
+  (lambda (node env)
+    (let ((exps (cdr (node-form node)))) 
+      (if (null? exps)
+	  (unspecific)
+	  (let loop ((exps exps))
+	    (cond ((null? (cdr exps))
+		   (eval (car exps) env))
+		  (else
+		   (eval (car exps) env)
+		   (loop (cdr exps)))))))))
+
+(define-evaluator 'if 
+  (lambda (node env)
+    (let* ((form (node-form node))
+	   (test (cadr form))
+	   (arms (cddr form)))
+      (cond ((eval test env)
+	     (eval (car arms) env))
+	    ((null? (cdr arms))
+	     (unspecific))
+	    (else
+	     (eval (cadr arms) env))))))
+
+(define-evaluator 'loophole
+  (lambda (node env)
+    (eval (caddr (node-form node)) env)))
+
+(define-evaluator 'letrec
+  (lambda (node env)
+    (let ((form (node-form node)))
+      (let ((vars (map car (cadr form)))
+	    (vals (map cadr (cadr form)))
+	    (body (caddr form)))
+	(let ((env (extend-env env
+			       vars
+			       (map (lambda (ignore)
+				      (unspecific))
+				    vars))))
+	  (for-each (lambda (var val)
+		      (env-set! env var (eval val env)))
+		    vars
+		    vals)
+	  (eval body env))))))
+
+(define (unspecific? x)
+  (eq? x (unspecific)))
+
+; Used by our clients but not by us.
+
+(define (constant? x)
+  (or (number? x)
+      (symbol? x)
+      (external-constant? x)
+      (external-value? x)
+      (boolean? x)))
diff --git a/ps-compiler/prescheme/expand.scm b/ps-compiler/prescheme/expand.scm
new file mode 100644
index 0000000..3cd44b2
--- /dev/null
+++ b/ps-compiler/prescheme/expand.scm
@@ -0,0 +1,77 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+; Expanding using the Scheme 48 expander.
+
+(define (scan-packages packages)
+  (let ((definitions
+	  (fold (lambda (package definitions)
+		  (let ((cenv (package->environment package)))
+		    (fold (lambda (form definitions)
+			    (let ((node (expand-form form cenv)))
+			      (cond ((define-node? node)
+				     (cons (eval-define (expand node cenv)
+							cenv)
+					   definitions))
+				    (else
+				     (eval-node (expand node cenv)
+						global-ref
+						global-set!
+						eval-primitive)
+				     definitions))))
+			  (call-with-values
+			   (lambda ()
+			     (package-source package))
+			   (lambda (files.forms usual-transforms primitives?)
+			     (scan-forms (apply append (map cdr files.forms))
+					 cenv)))
+			  definitions)))
+		packages
+		'())))
+    (reverse (map (lambda (var)
+		    (let ((value (variable-flag var)))
+		      (set-variable-flag! var #f)
+		      (cons var value)))
+		  definitions))))
+
+(define package->environment (structure-ref packages package->environment))
+
+(define define-node? (node-predicate 'define))
+
+(define (eval-define node cenv)
+  (let* ((form (node-form node))
+	 (value (eval-node (caddr form)
+			   global-ref
+			   global-set!
+			   eval-primitive))
+	 (lhs (cadr form)))
+    (global-set! lhs value)
+    (name->variable-or-value lhs)))
+
+(define (global-ref name)
+  (let ((thing (name->variable-or-value name)))
+    (if (variable? thing)
+	(variable-flag thing)
+	thing)))
+
+(define (global-set! name value)
+  (let ((thing (name->variable-or-value name)))
+    (if (primitive? thing)
+	(bug "trying to set the value of primitive ~S" thing)
+	(set-variable-flag! thing value))))
+
+(define (name->variable-or-value name)
+  (let ((binding (node-ref name 'binding)))
+    (if (binding? binding)
+	(let ((value (binding-place binding))
+	      (static (binding-static binding)))
+	  (cond ((primitive? static)
+		 static)
+		((variable? value)
+		 value)
+		((and (location? value)
+		      (constant? (contents value)))
+		 (contents value))
+		(else
+		 (bug "global binding is not a variable, primitive or constant ~S" name))))
+	(user-error "unbound variable ~S" (node-form name)))))
+
diff --git a/ps-compiler/prescheme/flatten.scm b/ps-compiler/prescheme/flatten.scm
new file mode 100644
index 0000000..13b5a4e
--- /dev/null
+++ b/ps-compiler/prescheme/flatten.scm
@@ -0,0 +1,406 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+; Definitions are (<variable> . <value>) pairs, where <value> can be any
+; Scheme value.  This code walks the values looking for sharing and for
+; closures.  Shared values are collected in a list and additional definitions
+; are introduced for the bindings in the environments of closures and for
+; close-compiled versions of any primitives in non-call position.  References
+; to closure-bound variables are replaced with references to the newly-created
+; package variables.
+
+(define (flatten-definitions definitions)
+  (set! *shared* '())
+  (set! *definitions* '())
+  (set! *immutable-value-table* (make-value-table))
+  (set! *closed-compiled-primitives* (make-symbol-table))
+  (let loop ((defs definitions) (flat '()))
+    (cond ((not (null? defs))
+	   (let ((var (caar defs))
+		 (value (cdar defs)))
+	     (if (and (variable-set!? var)
+		      (closure? value))
+		 (let ((new (generate-top-variable (variable-name var))))
+		   (loop `((,var . ,new)
+			   (,new . ,value)
+			   . ,defs)
+			 flat))
+		 (loop (cdr defs)
+		       (cons (cons var (flatten-value value))
+			     flat)))))
+	  ((null? *definitions*)
+	   (let ((forms (really-make-forms flat *shared*)))
+	     (set! *shared* #f)       ; safety
+	     (set! *closed-compiled-primitives* #f)
+	     (set! *immutable-value-table* #f)
+	     forms))
+	  (else
+	   (let ((defs *definitions*))
+	     (set! *definitions* '())
+	     (loop defs flat))))))
+
+; <Definitions> is a list of (<variable> . <value>) pairs.
+; <Shared> is a list of all shared objects, each of which must end up being
+; bound to a variable.
+
+(define (really-make-forms definitions shared)
+  (for-each (lambda (defn)
+	      (let ((var (car defn))
+		    (shared (value-shared (cdr defn))))
+		(if (and (not (variable-set!? var))
+			 shared
+			 (not (shared-variable shared)))
+		    (set-shared-variable! shared var))))
+	    definitions)
+  (map definition->form
+       (append definitions
+	       (shared-values->definitions shared))))
+
+(define variable-set!? (structure-ref forms variable-set!?))
+
+(define (shared-values->definitions shared)
+  (do ((shared shared (cdr shared))
+       (defns '() (if (shared-variable (value-shared (car shared)))
+		      defns
+		      (let ((var (generate-top-variable #f)))
+			(set-shared-variable! (value-shared (car shared)) var)
+			(cons (cons var (car shared)) defns)))))
+      ((null? shared)
+       defns)))
+
+(define (definition->form definition)
+  (let* ((var (car definition))
+	 (value (cdr definition))
+	 (shared (value-shared value))
+	 (value (if (or (not shared)
+			(eq? var (shared-variable shared)))
+		    value
+		    (shared-variable shared)))
+	 (clean (clean-value! value)))
+    ((structure-ref forms make-form)
+       var
+       (if (or (node? clean)
+	       (variable? clean))
+	   clean
+	   (make-literal-node clean))
+       (if (closure? value)              
+	   (cdr (shared-saved (closure-temp value))) ; free vars
+	   (stored-value-free-vars clean)))))
+
+(define (make-literal-node value)
+  (make-node op/literal value))
+
+(define (make-name-node value)
+  (make-node op/name value))
+
+(define *shared* '())
+
+(define (add-shared! value)
+  (set! *shared* (cons value *shared*)))
+
+(define *definitions* '())
+
+(define (add-package-definition! value id)
+  (let ((var (generate-top-variable id)))
+    (set! *definitions*
+	  (cons (cons var value)
+		*definitions*))
+    var))
+
+(define (generate-top-variable maybe-id)
+  (let ((var (make-global-variable (concatenate-symbol
+				      (if maybe-id
+					  (schemify maybe-id)
+					  'top.)
+				      (next-top-id))
+				   type/undetermined)))
+    (set-variable-flags! var
+			 (cons 'generated-top-variable
+			       (variable-flags var)))
+    var))
+
+(define *next-top-id* 0)
+
+(define (next-top-id)
+  (let ((id *next-top-id*))
+    (set! *next-top-id* (+ 1 *next-top-id*))
+    id))
+
+(define (generated-top-variable? var)
+  (memq? 'generated-top-variable (variable-flags var)))
+
+(define (stored-value-free-vars value)
+  (let ((vars '()))
+    (let label ((value value))
+      (cond ((variable? value)
+	     (cond ((not (variable-flag value))
+		    (set-variable-flag! value #t)
+		    (set! vars (cons value vars)))
+		   (else
+		    ;(breakpoint "marked variable")  ; why did I care?
+		    (values))))
+	    ((vector? value)
+	     (do ((i 0 (+ i 1)))
+		 ((= i (vector-length value)))
+	       (label (vector-ref value i))))
+	    ((pair? value)
+	     (label (car value))
+	     (label (cdr value)))))
+    (for-each (lambda (var)
+		(set-variable-flag! var #f))
+	      vars)
+    vars))
+
+;----------------------------------------------------------------
+; Finding shared data structures.
+
+(define-record-type shared
+  ()
+  (saved
+   (shared? #f)
+   (variable #f)))
+
+(define make-shared shared-maker)
+
+(define (value-shared value)
+  (cond ((pair? value)
+	 (car value))
+	((vector? value)
+	 (if (= 0 (vector-length value))
+	     #f
+	     (vector-ref value 0)))
+	((closure? value)
+	 (closure-temp value))
+	(else
+	 #f)))
+
+(define (clean-value! value)
+  (cond ((pair? value)
+	 (cons (clean-sub-value! (shared-saved (car value)))
+	       (clean-sub-value! (cdr value))))
+	((vector? value)
+	 (if (= 0 (vector-length value))
+	     value
+	     (let ((new (make-vector (vector-length value))))
+	       (vector-set! new 0 (clean-sub-value!
+				   (shared-saved (vector-ref value 0))))
+	       (do ((i 1 (+ i 1)))
+		   ((= i (vector-length value)))
+		 (vector-set! new i (clean-sub-value! (vector-ref value i))))
+	       new)))
+	((closure? value)
+	 (car (shared-saved (closure-temp value)))) ; flattened version of node
+	((node? value)
+	 (if (name-node? value)
+	     (name-node->variable value)
+	     (bug "bad definition value: ~S" value)))
+	(else
+	 value)))
+
+(define name-node? (node-predicate 'name))
+
+(define (clean-sub-value! value)
+  (cond ((pair? value)
+	 (let ((shared (car value)))
+	   (cond ((shared-shared? shared)
+		  (shared-variable shared))
+		 (else
+		  (set-car! value (clean-sub-value! (shared-saved shared)))
+		  (set-cdr! value (clean-sub-value! (cdr value)))
+		  value))))
+	((vector? value)
+	 (cond ((= 0 (vector-length value))
+		value)
+	       ((shared-shared? (vector-ref value 0))
+		(shared-variable (vector-ref value 0)))
+	       (else
+		(vector-set! value 0 (clean-sub-value!
+				      (shared-saved (vector-ref value 0))))
+		(do ((i 1 (+ i 1)))
+		    ((= i (vector-length value)))
+		  (vector-set! value i (clean-sub-value! (vector-ref value i))))
+		value)))
+	((closure? value)
+	 (shared-variable (closure-temp value)))
+	(else
+	 value)))
+
+(define (flatten-value value)
+  (cond ((immutable? value)
+	 (flatten-immutable-value value))
+	((primitive? value)
+	 (primitive->name-node value))
+	(else
+	 (flatten-value! value)
+	 value)))
+
+(define (flatten-value! value)
+  (cond ((pair? value)
+	 (check-shared! (car value) flatten-pair! value))
+	((vector? value)
+	 (if (not (= 0 (vector-length value)))
+	     (check-shared! (vector-ref value 0) flatten-vector! value)))
+	((closure? value)
+	 (check-shared! (closure-temp value) flatten-closure! value))))
+
+(define (check-shared! shared flatten! value)
+  (cond ((not (shared? shared))
+	 (flatten! value))
+	((not (shared-shared? shared))
+	 (set-shared-shared?! shared #t)
+	 (add-shared! value))))
+
+(define *immutable-value-table* #f)
+
+(define (flatten-immutable-value value)
+  (cond ((pair? value)
+	 (or (shared-immutable-value value car)
+	     (let ((p (cons (car value) (cdr value))))
+	       (table-set! *immutable-value-table* value p)
+	       (flatten-pair! p)
+	       p)))
+	((vector? value)
+	 (if (= 0 (vector-length value))
+	     value
+	     (or (shared-immutable-value value (lambda (x) (vector-ref x 0)))
+		 (let ((v (copy-vector value)))
+		   (table-set! *immutable-value-table* value v)
+		   (flatten-vector! v)
+		   v))))
+	; no immutable closures
+	(else
+	 value)))  ; no sub-values
+
+(define (shared-immutable-value value accessor)
+  (cond ((table-ref *immutable-value-table* value)
+	 => (lambda (copy)
+	      (cond ((not (shared-shared? (accessor copy)))
+		     (set-shared-shared?! (accessor copy) #t)
+		     (add-shared! copy)
+		     copy))))
+	(else
+	 #f)))
+
+(define (flatten-pair! pair)
+  (let ((temp (car pair))
+	(shared (make-shared)))
+    (set-car! pair shared)
+    (set-shared-saved! shared (flatten-value temp))
+    (set-cdr! pair (flatten-value (cdr pair)))))
+
+(define (flatten-vector! vector)
+  (let ((temp (vector-ref vector 0))
+	(shared (make-shared)))
+    (vector-set! vector 0 shared)
+    (set-shared-saved! shared (flatten-value temp))
+    (do ((i 1 (+ i 1)))
+	((= i (vector-length vector)))
+      (vector-set! vector i (flatten-value (vector-ref vector i))))))
+
+; Make top-level definitions for the bindings in the closure and then substitute
+; the defined variables within the closure's code.  The define variables are
+; saved in the bindings in case they are shared with other closures (both for
+; efficiency and because SET! requires it).
+
+(define (flatten-closure! closure)
+  (let ((shared (make-shared)))
+    (for-each flatten-closure-binding! (closure-env closure))
+    (set-closure-temp! closure shared)
+    (set-shared-shared?! shared #t)     ; closures always need definitions
+    (add-shared! closure)
+    (receive (exp free)
+	(substitute-in-expression (closure-node closure))
+      (set-shared-saved! shared (cons exp free))
+      (for-each clear-closure-binding! (closure-env closure)))))
+
+(define (clear-closure-binding! pair)
+  (node-set! (car pair) 'substitute #f))
+
+; PAIR is (<name-node> . <value>) if it hasn't been seen before and
+; (<name-node> . <substitute-name-node>) if it has.
+
+(define (flatten-closure-binding! pair)
+  (let* ((name (car pair))
+	 (subst (if (node? (cdr pair))
+		    (cdr pair)
+		    (let ((subst (make-name-node-subst name (cdr pair))))
+		      (set-cdr! pair subst)
+		      subst))))
+    (node-set! name 'substitute subst)))
+
+(define (make-name-node-subst name value)		      
+  (let ((var (add-package-definition! value (node-form name)))
+	(subst (make-similar-node name (node-form name))))
+    (node-set! subst 'binding (make-binding #f var #f))
+    subst))
+
+(define op/literal (get-operator 'literal))
+(define op/name    (get-operator 'name))
+
+;----------------------------------------------------------------
+(define *closed-compiled-primitives* #f)
+
+(define (make-primitive-node primitive call?)
+  (if (and call?
+	   (primitive-expands-in-place? primitive))
+      (make-node op/primitive primitive)
+      (let ((name-node (primitive->name-node primitive)))
+	(note-variable-use! (name-node->variable name-node))
+	name-node)))
+
+(define (name-node->variable name-node)
+  (let ((binding (node-ref name-node 'binding)))
+    (cond ((not (binding? binding))
+	   (bug "unbound variable ~S" (node-form name-node)))
+	  ((primitive? (binding-static binding))
+	   (primitive->name-node (binding-static binding)))
+	  (else
+	   (binding-place binding)))))
+
+(define (primitive->name-node primitive)
+  (let ((id (primitive-id primitive)))
+    (or (table-ref *closed-compiled-primitives* id)
+	(let* ((var (add-package-definition!
+		     (make-top-level-closure
+		      (expand (primitive-source primitive)
+			      prescheme-compiler-env))
+		     id))
+	       (binding (make-binding #f var #f))
+	       (node (make-node op/name id)))
+	  (node-set! node 'binding (make-binding #f var #f))
+	  (table-set! *closed-compiled-primitives* id node)
+	  (set-variable-flags! var (cons 'closed-compiled-primitive
+					 (variable-flags var)))
+	  node))))
+
+(define op/primitive (get-operator 'primitive))
+
+;----------------------------------------------------------------
+
+(define max-key-depth 5)
+
+(define (value-table-hash-function obj)
+  (let recur ((obj obj) (depth 0))
+    (cond ((= depth max-key-depth)
+	   0)
+	  ((symbol? obj) (string-hash (symbol->string obj)))
+	  ((integer? obj)
+	   (if (< obj 0) (- -1 obj) obj))
+	  ((char? obj) (+ 333 (char->integer obj)))
+	  ((eq? obj #f) 3001)
+	  ((eq? obj #t) 3003)
+	  ((null? obj) 3005)
+	  ((pair? obj)
+	   (+ 3007
+	      (recur (car obj) (- depth 1))
+	      (* 3 (recur (cdr obj) (- depth 1)))))
+	  ((vector? obj)
+	   (let loop ((i 0) (hash (+ 3009 (vector-length obj))))
+	     (if (or (= i (vector-length obj))
+		     (= 0 (- depth i)))
+		 hash
+		 (loop (+ i 1) (+ hash (* i (recur (vector-ref obj i)
+						   (- depth i))))))))
+	  (else (error "value cannot be used as a table key" obj)))))
+
+(define make-value-table
+  (make-table-maker eq? value-table-hash-function))
diff --git a/ps-compiler/prescheme/form.scm b/ps-compiler/prescheme/form.scm
new file mode 100644
index 0000000..094f80a
--- /dev/null
+++ b/ps-compiler/prescheme/form.scm
@@ -0,0 +1,666 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+; temporary hack
+;(define enqueue! enqueue)
+;(define dequeue! dequeue)
+
+(define-record-type form
+  (var              ; variable being defined (if any)
+   (value)          ; current value
+   ;source           ; one line of source code
+   (free)           ; variables free in this form
+   )
+
+  (used?            ; is the value used in the program
+   (exported? #f)   ; true if the definition in this form is exported
+   (integrate 'okay) ; one of OKAY, YES, NO, PARTIAL
+   (aliases   '())  ; variables that are aliases for this one
+   (shadowed  '())  ; package variables that should be shadowed here
+
+   value-type       ; value's type
+
+   (dependency-index #f) ; index of this form in the data dependent order
+
+   lambdas          ; list of all non-cont lambdas in this form
+
+   (clients '())    ; forms that use this one's variable
+   (providers '())  ; forms that define a variable used by this one
+   
+   (type #f)        ; one of LAMBDA, INTEGRATE, INITIALIZE or
+                    ;  #F for unfinished forms
+   merge            ; slot used by form-merging code
+   temp             ; handy slot
+   ))
+
+(define-record-discloser type/form
+  (lambda (form)
+    `(form ,(variable-name (form-var form)))))
+
+(define (make-form var value free)
+  (let ((form (form-maker var value free)))
+    (if (maybe-variable->form var)
+	(error "more than one definition of ~S" (variable-name var)))
+    (set-variable-flags! var `((form . ,form) . ,(variable-flags var)))
+    form))
+
+(define (pp-one-line x)
+  (call-with-string-output-port
+   (lambda (p)
+     (write-one-line p 70 (lambda (p) (write x p))))))
+
+(define (form-node form)
+  (let ((value (form-value form)))
+    (if (node? value)
+	value
+	(bug "form's value is not a node ~S ~S" form value))))
+
+(define (set-form-node! form node lambdas)
+  (set-node-flag! node form)
+  (set-form-value! form node)
+  (set-form-lambdas! form lambdas))
+
+(define (node-form node)
+  (let ((form (node-flag (node-base node))))
+    (if (form? form)
+	form
+	(bug "node ~S (~S) not in any form" node (node-base node)))))
+
+(define (suspend-form-use! form)
+  (set-form-lambdas! form (make-lambda-list))
+  (set-node-flag! (form-node form) form))
+
+(define (use-this-form! form)
+  (initialize-lambdas)
+  (also-use-this-form! form))
+
+(define (also-use-this-form! form)
+  (add-lambdas (form-lambdas form))
+  (set-node-flag! (form-node form) #f))
+
+(define (form-name form)
+  (variable-name (form-var form)))
+
+(define (make-form-unused! form)
+  (set-form-type! form 'unused)
+  (cond ((node? (form-value form))
+	 (erase (form-value form))
+	 (set-form-value! form #f)
+	 (set-form-lambdas! form #f))))
+
+; notes on writing and reading forms
+; What we really need here are forms.
+; What to do?  Can read until there are no missing lambdas = end of form
+; Need the variables as well.
+
+; (form index type var source? clients providers integrate?)
+; clients and providers are lists of indicies
+; can get lambdas automatically
+
+;(define (write-cps-file file forms)
+;  (let ((port (make-tracking-output-port (open-output-file file))))
+;    (reset-pp-cps)
+;    (walk (lambda (f)
+;	    (write-form f port))
+;	  (sort-list forms
+;		     (lambda (f1 f2)
+;		       (< (form-index f1) (form-index f2)))))
+;    (close-output-port port)))
+
+;(define (write-form form port)
+;  (format port "(FORM ~D ~S ~S "
+;	  (form-index form)
+;	  (form-type form)
+;	  (form-integrate form))
+;  (if (form-var form)
+;      (print-variable-name (form-var form) port)
+;      (format port "#f"))
+;  (format port "~%  ~S" (map form-index (form-clients form)))
+;  (rereadable-pp-cps (form-value form) port)
+;  (format port ")~%~%"))
+
+;------------------------------------------------------------------------------
+; Put the forms that do not reference any other forms' variables in a queue.
+; Every form gets a list of forms that use its variable and a list of forms
+; whose variables it uses.
+
+(define (sort-forms forms)
+  (let ((queue (make-queue)))
+    (for-each (lambda (f)
+		(set-variable-flag! (form-var f) f))
+	      forms)
+    (let ((forms (really-remove-unreferenced-forms
+		  forms
+		  set-providers-using-free)))
+      (for-each (lambda (f)
+		  (if (null? (form-providers f))
+		      (enqueue! queue f)))
+		(reverse forms))
+      (for-each (lambda (f)
+		  (set-variable-flag! (form-var f) #f))
+		forms)
+      (values forms (make-form-queue queue forms)))))
+
+(define (set-providers-using-free form)
+  (let loop ((vars (form-free form)) (provs '()))
+    (cond ((null? vars)
+	   (set-form-providers! form provs))
+	  ((variable-flag (car vars))
+	   => (lambda (prov)
+		(set-form-clients! prov (cons form (form-clients prov)))
+		(loop (cdr vars) (cons prov provs))))
+	  (else
+	   (loop (cdr vars) provs)))))
+
+(define (make-form-queue ready forms)
+  (let ((index 0))
+    (lambda ()
+      (let loop ()
+	(cond ((not (queue-empty? ready))
+	       (let ((form (dequeue! ready)))
+		 (set-form-dependency-index! form index)
+		 (for-each (lambda (f)
+			     (set-form-providers! f (delq! form (form-providers f)))
+			     (if (and (null? (form-providers f))
+				      (not (form-dependency-index f))
+				      (form-used? f))
+				 (enqueue! ready f)))
+			   (form-clients form))
+		 (set! index (+ index 1))
+		 form))
+	      ((find-dependency-loop ready forms)
+	       => (lambda (rest)
+		    (set! forms rest)
+		    (loop)))
+	      (else #f))))))
+
+; Find a circular dependence between the remaining forms.
+
+(define (find-dependency-loop queue forms)
+  (let ((forms (do ((forms forms (cdr forms)))
+                   ((or (null? forms)
+			(not (form-dependency-index (car forms))))
+                    forms))))
+    (cond ((null? forms)
+           #f)
+          (else
+           ;;(format #t "Dependency loop!~%")
+           (let ((form (really-find-dependency-loop forms)))
+	     (if (not (every? (lambda (f) (eq? 'no (form-integrate f)))
+			      (form-providers form)))
+		 (set-form-integrate! form 'no))
+             (set-form-providers! form '())
+             (enqueue! queue form)
+             forms)))))
+
+(define (really-find-dependency-loop forms)
+  (for-each (lambda (f) (set-form-temp! f #f))
+	    forms)
+  (let label ((form (car forms)))
+    (cond ((form-temp form)
+           (break-dependency-loop (filter (lambda (f)
+					    (and (form-temp f) (form-var f)))
+					  forms)))
+          (else
+           (set-form-temp! form #t)
+           (cond ((any-map label (form-providers form))
+                  => (lambda (res)
+                       (set-form-temp! form #f)
+                       res))
+                 (else
+                  (set-form-temp! form #f)
+                  #f))))))
+
+(define (any-map proc list)
+  (let loop ((list list))
+    (cond ((null? list)
+	   #f)
+	  ((proc (car list))
+	   => identity)
+	  (else
+	   (loop (cdr list))))))
+
+(define *loop-forms* #f)
+
+(define (break-dependency-loop forms)
+  (or (first (lambda (f)
+               (or (every? (lambda (f)
+                             (eq? 'no (form-integrate f)))
+                           (form-providers f))
+                   (memq? f (form-providers f))
+		   (and (scheme-node? (form-value f))
+			(scheme-literal-node? (form-value f)))))
+             forms)
+      (begin (set! *loop-forms* forms)
+	     (let ((f (breakpoint "Break dependency loop: *loop-forms* = ~S" forms)))
+	       (set! *loop-forms* #f)
+	       f))))
+
+(define scheme-literal-node? 
+  ((structure-ref nodes node-predicate) 'literal))
+
+(define scheme-node? 
+  (structure-ref nodes node?))
+
+;----------------------------------------------------------------
+
+(define (variable-set!? var)
+  (memq 'set! (variable-flags var)))
+
+(define (note-variable-set!! var)
+  (if (not (variable-set!? var))
+      (set-variable-flags! var (cons 'set! (variable-flags var)))))
+
+;------------------------------------------------------------------------------
+; Turn expression into nodes and simplify it.
+
+; Still to do:
+;  Get representations of data values
+;  Need to constant fold vector slots, including detection of modifications
+;    and single uses.
+
+(define (expand-and-simplify-form form)
+  (initialize-lambdas)
+  (let* ((value (form-value form))
+	 (node (if (variable? value)
+		   (make-reference-node value)
+		   (x->cps (form-value form) (form-name form)))))
+    (cond ((variable-set!? (form-var form))
+	   (set-form-type! form 'initialize)
+	   (set-form-node! form node '())
+	   "settable")
+         ((reference-node? node)
+	  (let ((var (reference-variable node)))
+	    (add-known-form-value! form node)
+	    (cond ((maybe-variable->form var)
+		   => (lambda (f)
+			(set-form-aliases! f
+					   `(,(form-var form)
+					     ,@(form-aliases form)
+					     . ,(form-aliases f))))))
+	    (set-form-type! form 'alias)
+	    (erase node)
+	    (set-form-value! form var)
+	    "alias"))
+	 ((literal-node? node)
+	  (expand-and-simplify-literal node form))
+	 ((lambda-node? node)
+	  (expand-and-simplify-lambda node form))
+	 (else
+	  (bug "funny form value ~S" node)))))
+
+; This could pay attention to immutability.
+
+(define (atomic? value)
+  (not (or (vector? value)
+	   (pair? value))))
+
+(define (expand-and-simplify-literal node form)
+  (let ((value (literal-value node)))
+    (cond ((unspecific? value)
+	   (format #t "~%Warning: variable `~S' has no value and is not SET!~%"
+		   (form-name form))
+	   (set-form-value! form node)
+	   (set-form-lambdas! form '())
+	   (set-form-integrate! form 'no)
+	   (set-form-type! form 'unused)
+           "constant")
+	  ((atomic? value)
+	   (add-known-form-value! form node)
+	   (set-form-value! form node)
+	   (set-form-lambdas! form '())
+	   "constant")
+	  (else
+	   (set-form-node! form (stob->node value) '())
+	   (set-form-type! form 'stob)
+	   "consed"))))
+
+; Make a call node containing the contents of the stob so that any
+; variables will be seen as referenced and any integrable values will
+; be integrated.
+
+; Only works for vectors at this point.
+; MAKE-VECTOR is a randomly chosen primop, almost anything could be used.
+
+(define (stob->node value)
+  (let* ((contents '())
+	 (add! (lambda (x) (set! contents (cons x contents)))))
+    (cond ((vector? value)
+	   (do ((i 0 (+ i 1)))
+	       ((>= i (vector-length value)))
+	     (add! (vector-ref value i))))
+	  (else
+	   (error "unknown kind of stob value ~S" value)))
+    (let ((call (make-call-node (get-prescheme-primop 'make-vector)
+				(+ 1 (length contents))
+				0))
+	  (node (make-lambda-node 'stob 'init '())))
+      (attach call 0 (make-literal-node value #f)) ; save for future use
+      (do ((i 1 (+ i 1))
+	   (cs (reverse contents) (cdr cs)))
+	  ((null? cs))
+	(let ((x (car cs)))
+	  (attach call i (if (variable? x)
+			     (make-reference-node x)
+			     (make-literal-node x type/unknown)))))
+      (attach-body node call)
+      (simplify-args call 1)
+      node)))
+
+(define (add-known-form-value! form value)
+  (let ((node (if (variable? value)
+		  (make-reference-node value)
+		  value))
+	(var (form-var form)))
+    (set-form-type! form 'integrate)
+    (cond ((or (literal-node? node)
+	       (reference-node? node)
+	       (and (call-node? node)
+		    (trivial? node)))
+	   (add-variable-known-value! var (node->vector node))
+	   (if (variable? value)
+	       (erase node)))
+	  ((lambda-node? node)
+	   (add-variable-simplifier! var (make-inliner (node->vector node))))
+	  (else
+	   (bug "form's value ~S is not a value" value)))))
+
+(define (make-inliner vector)
+  (lambda (call)
+    (let ((proc (call-arg call 1)))
+      (replace proc (reconstruct-value vector proc call)))))
+
+(define (reconstruct-value value proc call)
+  (let ((has-type (maybe-follow-uvar (variable-type (reference-variable proc))))
+	(node (vector->node value)))
+    (if (type-scheme? has-type)
+	(instantiate-type&value has-type node proc))
+    node))
+
+(define (expand-and-simplify-lambda node form)
+  (simplify-all node (form-name form))
+  (let ((lambdas (make-lambda-list))
+	(status (duplicate-form? form node)))
+    (if status
+	(add-known-form-value! form node))
+    (set-form-node! form node lambdas)
+    (set-form-type! form 'lambda)
+    (set-form-free! form #f)   ; old value no longer valid
+    status))
+
+(define *duplicate-lambda-size* 10)
+
+(define (set-duplicate-lambda-size! n)
+  (set! *duplicate-lambda-size* n))
+
+(define (duplicate-form? form node)
+  (cond ((or (variable-set!? (form-var form))
+	     (eq? 'no (form-integrate form)))
+         #f)
+        ((small-node? node *duplicate-lambda-size*)
+	 "small")
+	((eq? 'yes (form-integrate form))
+	 "by request")
+;        ((called-arguments? node)
+;         "called arguments")
+        (else
+         #f)))
+
+(define (called-arguments? node)
+  (any? (lambda (v)
+	  (any? (lambda (n)
+		  (eq? n (called-node (node-parent n))))
+		(variable-refs v)))
+	(cdr (lambda-variables node))))
+
+;------------------------------------------------------------------------------
+
+(define (integrate-stob-form form)
+  (if (and (eq? 'stob (form-type form))
+	   (elide-aliases! form)
+	   (not (form-exported? form))
+	   (every? cell-use (variable-refs (form-var form))))
+      (let* ((var (form-var form))
+	     (ref (car (variable-refs var)))
+	     (call (lambda-body (form-value form))))
+	; could fold any fixed references - do it later
+	(cond ((and (null? (cdr (variable-refs var)))
+		    (called-node? (cell-use ref)))
+	       (format #t "computed-goto: ~S~%" (variable-name var)) 
+	       (make-computed-goto form))))))
+
+(define (cell-use node)
+  (let ((parent (node-parent node)))
+    (if (and (call-node? parent)
+	     (eq? 'vector-ref (primop-id (call-primop parent))))
+	parent
+	#f)))
+
+(define (elide-aliases! form)
+  (not (or-map (lambda (f)
+		 (switch-references! (form-var f) (form-var form))
+		 (form-exported? f))
+	       (form-aliases form))))
+
+(define (switch-references! from to)
+  (for-each (lambda (r)
+	      (set-reference-variable! r to))
+	    (variable-refs from))
+  (set-variable-refs! to (append (variable-refs from) (variable-refs to))))
+
+;------------------------------------------------------------------------------
+
+(define (resimplify-form form)
+  (let ((node (form-value form)))
+    (cond ((and (node? node)
+		(not (eq? 'stob (form-type form)))
+		(not (node-simplified? node)))
+	   (use-this-form! form)
+	   (simplify-node node)
+	   (suspend-form-use! form)))))
+
+;------------------------------------------------------------------------------
+; This is removes all forms that are not ultimately referenced from some
+; exported form.
+
+(define (add-form-provider! form provider)
+  (if (not (memq? provider (form-providers form)))
+      (set-form-providers!
+       form
+       (cons provider (form-providers form)))))
+
+(define (variable->form var)
+  (or (maybe-variable->form var)
+      (bug "variable ~S has no form" var)))
+
+(define (maybe-variable->form var)
+  (cond ((flag-assq 'form (variable-flags var))
+	 => cdr)
+	(else
+	 #f)))
+
+(define (remove-unreferenced-forms forms)
+  (really-remove-unreferenced-forms forms set-form-providers))
+
+(define (really-remove-unreferenced-forms forms set-form-providers)
+  (receive (exported others)
+      (partition-list form-exported? forms)
+    (for-each (lambda (f)
+		(set-form-providers! f '())
+		(set-form-clients!   f '())
+		(set-form-used?!     f (form-exported? f)))
+	      forms)
+    (for-each set-form-providers forms)
+    (propogate-used?! exported)
+    (append (remove-unused-forms others) exported)))
+
+(define (set-form-providers form)
+  (for-each (lambda (n)
+	      (add-form-provider! (node-form n) form))
+	    (variable-refs (form-var form)))
+  (if (eq? (form-type form) 'alias)
+      (add-form-provider! form (variable->form (form-value form)))))
+
+(define (propogate-used?! forms)
+  (let loop ((to-do forms))
+    (if (not (null? to-do))
+	(let loop2 ((providers (form-providers (car to-do)))
+		    (to-do (cdr to-do)))
+	  (if (null? providers)
+	      (loop to-do)
+	      (loop2 (cdr providers)
+		     (let ((p (car providers)))
+		       (cond ((form-used? p)
+			      to-do)
+			     (else
+			      (set-form-used?! p #t)
+			      (cons p to-do))))))))))
+
+; Actually remove forms that are not referenced.
+
+(define (remove-unused-forms forms)
+;  (format #t "Removing unused forms~%")
+  (filter (lambda (f)
+	    (cond ((or (not (form-used? f))
+		       )
+		       ;(let ((value (form-value f)))
+			; (and (quote-exp? value)
+			 ;     (external-value? (quote-exp-value value))))
+;		   (format #t " ~S~%" (variable-name (form-var f)))
+		   (erase-variable (form-var f))
+		   (cond ((node? (form-value f))
+			  (erase (form-value f))
+			  (set-form-value! f #f)
+			  (set-form-lambdas! f '())))
+		   #f)
+		  (else #t)))
+	  forms))
+
+;------------------------------------------------------------
+; Total yucko.
+
+; (unknown-call (lambda e-vars e-body)
+;               protocol
+;               (vector-ref x offset)
+;               . args)
+; =>
+; (let (lambda ,vars
+;        (computed-goto
+;          ...
+;          (lambda ()
+;            (unknown-call (lambda ,copied-evars
+;                            (jump ,(car vars) ,copied-evars))
+;                          ,(vector-ref proc-vector i)
+;                          . ,(cdr vars)))
+;          ...
+;          '((offsets ...) ...)    ; offsets for each continuation
+;          ,offset))
+;      ,exit
+;      . ,args)
+
+(define (make-computed-goto form)
+  (let* ((ref (car (variable-refs (form-var form))))
+	 (in-form (node-form ref))
+	 (entries (vector->offset-map (call-args (lambda-body (form-node form))))))
+    (use-this-form! in-form)
+    (also-use-this-form! form)
+    (really-make-computed-goto (node-parent ref) entries)
+    (erase (form-node form))
+    (set-form-value! form #f)
+    (set-form-lambdas! form #f)
+    (simplify-node (form-node in-form))
+    (suspend-form-use! in-form)))
+
+; Returns a list ((<node> . <offsets>) ...) where <offsets> are where <node>
+; was found in VECTOR.  The first element of VECTOR is a marker which we
+; pretend isn't there.
+;
+; This would be more effective if done by a simplifier after the continuations
+; had been simplified.
+
+(define (vector->offset-map vector)
+  (let loop ((i 0) (res '()))
+    (if (= (+ i 1) (vector-length vector))
+	(reverse (map (lambda (p)
+			(cons (car p) (reverse (cdr p))))
+		      res))
+	(let ((n (vector-ref vector (+ i 1))))
+	  (loop (+ i 1)
+		(cond ((first (lambda (p)
+				(node-equal? n (car p)))
+			      res)
+		       => (lambda (p)
+			    (set-cdr! p (cons i (cdr p)))
+			    res))
+		      (else
+		       (cons (list n i) res))))))))
+
+
+(define (really-make-computed-goto vec-ref entries)
+  (let* ((exits (length entries))
+	 (offset (call-arg vec-ref 1))
+	 (vector-call (node-parent vec-ref))
+	 (args (sub-vector->list (call-args vector-call) 3))
+	 (call (make-call-node (get-prescheme-primop 'computed-goto)
+			       (+ 2 exits)
+			       exits))
+	 (arg-vars (map (lambda (arg) (make-variable 't (node-type arg)))
+			args))
+	 (protocol (literal-value (call-arg vector-call 2)))
+	 (cont (call-arg vector-call 0)))
+    (for-each detach args)
+    (attach call exits (make-literal-node (map cdr entries) #f))
+    (attach call (+ exits 1) (detach offset))
+    (receive (top continuations)
+	(if (reference-node? cont)
+	    (make-computed-goto-tail-conts call args arg-vars entries cont protocol)
+	    (make-computed-goto-conts call args arg-vars entries cont protocol))
+      (do ((i 0 (+ i 1))
+	   (l continuations (cdr l)))
+	  ((= i exits))
+	(attach call i (car l)))
+      (replace-body vector-call top))))
+    
+(define (make-computed-goto-tail-conts call args arg-vars entries cont protocol)
+  (let-nodes ((top (let 1 l1 . args))
+	      (l1 arg-vars call))
+    (values top (map (lambda (p)
+		       (computed-goto-tail-exit
+			(detach (car p))
+			protocol
+			(reference-variable cont)
+			arg-vars))
+		     entries))))
+
+(define (computed-goto-tail-exit node protocol cont-var arg-vars)
+  (let ((args (map make-reference-node arg-vars)))
+    (let-nodes ((l1 () (unknown-tail-call 0 (* cont-var)
+					  node
+					  '(protocol #f) . args)))
+      l1)))
+
+(define (make-computed-goto-conts call args arg-vars entries cont protocol)
+  (let ((cont-vars (lambda-variables cont))
+	(cont-type (make-arrow-type (map variable-type
+					 (lambda-variables cont))
+				    type/null)))
+    (detach cont)
+    (change-lambda-type cont 'jump)
+    (let-nodes ((top (let 1 l1 cont . args))
+		(l1 ((j cont-type) . arg-vars) call))
+      (values top
+	      (map (lambda (p)
+		     (computed-goto-exit (detach (car p))
+					 protocol
+					 arg-vars
+					 j
+					 cont-vars))
+		   entries)))))
+
+(define (computed-goto-exit node protocol arg-vars cont-var cont-vars)
+  (let* ((cont-vars (map copy-variable cont-vars))
+	 (cont-args (map make-reference-node cont-vars))
+	 (args (map make-reference-node arg-vars)))
+    (let-nodes ((l1 () (unknown-call 1 l2 node '(protocol #f) . args))
+		(l2 cont-vars (jump 0 (* cont-var) . cont-args)))
+      l1)))
+
diff --git a/ps-compiler/prescheme/front-end.scm b/ps-compiler/prescheme/front-end.scm
new file mode 100644
index 0000000..252d3a0
--- /dev/null
+++ b/ps-compiler/prescheme/front-end.scm
@@ -0,0 +1,133 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define (prescheme-front-end package-ids spec-files copy no-copy shadow)
+  (receive (packages exports lookup)
+      (package-specs->packages+exports package-ids spec-files)
+    (let ((forms (flatten-definitions (scan-packages packages))))
+      (annotate-forms! (car package-ids) lookup exports copy no-copy shadow)
+      (receive (forms producer)
+	  (sort-forms forms)
+	(format #t "Checking types~%")
+	(let ((sorted (let loop ((forms '()))
+			(cond ((producer)
+			       => (lambda (f)
+				    (type-check-form f)
+				    (loop (cons f forms))))
+			      (else
+			       (reverse forms))))))
+;	  (format #t "Adding coercions~%")
+;	  (add-type-coercions (form-reducer forms))
+	  sorted)))))
+
+(define (form-reducer forms)
+  (lambda (proc init)
+    (let loop ((forms forms) (value init))
+      (if (null? forms)
+	  value
+	  (loop (cdr forms)
+		(proc (form-name (car forms))
+		      (form-value (car forms))
+		      value))))))
+
+(define (test id files)
+  ((structure-ref node reset-node-id))
+  ((structure-ref record-types reset-record-data!))
+  (prescheme-front-end id files '() '() '()))
+
+(define (annotate-forms! package-id lookup exports copy no-copy shadow)
+  (mark-forms! exports
+	       lookup
+	       (lambda (f) (set-form-exported?! f #t))
+	       "exported")
+  (mark-forms! copy
+	       lookup
+	       (lambda (f) (set-form-integrate! f 'yes))
+	       "to be copied")
+  (mark-forms! no-copy
+	       lookup
+	       (lambda (f) (set-form-integrate! f 'no))
+	       "not to be copied")
+  (for-each (lambda (data)
+	      (let ((owner (package-lookup lookup (caar data) (cadar data))))
+		(if owner
+		    (mark-forms! (cdr data)
+				 lookup
+				 (lambda (f)
+				   (set-form-shadowed! owner
+						       (cons (form-var f)
+							     (form-shadowed owner))))
+				 (format #f "shadowed in ~S" (car data)))
+		    (format #t "Warning: no definition for ~S, cannot shadow ~S~%"
+			    (car data) (cdr data)))))
+	    shadow))
+
+(define (mark-forms! specs lookup marker mark)
+  (let ((lose (lambda (p n)
+		(format #t "Warning: no definition for ~S, cannot mark as ~A~%"
+			(list p n) mark))))
+    (for-each (lambda (spec)
+		(let ((package-id (car spec))
+		      (ids (cdr spec)))
+		  (for-each (lambda (id)
+			      (cond ((package-lookup lookup package-id id)
+				     => marker)
+				    (else
+				     (lose package-id id))))
+			    ids)))
+	      specs)))
+
+(define (package-lookup lookup package-id id)
+  (let ((var (lookup package-id id)))
+    (and (variable? var)
+	 (maybe-variable->form var))))
+
+; Two possibilities:
+; 1. The variable is settable but the thunk gives it no particular value.
+; 2. A real value is or needs to be present, so we relate the type of
+; the variable with the type of the value.
+
+; thunk's value may be a STOB and not a lambda.
+
+(define (type-check-form form)
+  ;; (format #t "  ~S: " (variable-name (form-var form)))
+  (let* ((value (form-value form))
+	 (var (form-var form))
+	 (name (form-name form))
+	 (value-type (cond (((structure-ref nodes node?) value)
+			    (infer-definition-type value (source-proc form)))
+			   ((variable? value)
+			    (get-package-variable-type value))
+			   (else
+			    (bug "unknown kind of form value ~S" value)))))
+    (set-form-value-type! form value-type)
+    (cond ((not (variable-set!? var))
+	   (let ((type (cond ((eq? type/unknown (variable-type var))
+			      (let ((type (schemify-type value-type 0)))
+				(set-variable-type! var type)
+				type))
+			     (else
+			      (unify! value-type (get-package-variable-type var) form)
+			      value-type))))
+	     (if (not (type-scheme? type))
+		 (make-nonpolymorphic! type)) ; lock down any related uvars
+	     ;;(format #t "~S~%" (instantiate type))
+	     ))
+	  ((not (or (eq? type/unit value-type)
+		    (eq? type/null value-type)))
+	   (make-nonpolymorphic! value-type) ; no polymorphism allowed (so it
+	   ;; is not checked for, so there may be depth 0 uvars in the type)
+	   ;; (format #t " ~S~%" (instantiate value-type))
+	   (unify! value-type (get-package-variable-type var) form))
+	  ((eq? type/unknown (variable-type var))
+	   (get-package-variable-type var)))))
+
+(define (source-proc form)
+  (lambda (port)
+    (write-one-line port
+		    70
+		    (lambda (port)
+		      (format port "~S = ~S"
+			      (form-name form)
+			      ((structure-ref nodes schemify)
+			         (form-value form)))))))
diff --git a/ps-compiler/prescheme/hoist.scm b/ps-compiler/prescheme/hoist.scm
new file mode 100644
index 0000000..c23de3c
--- /dev/null
+++ b/ps-compiler/prescheme/hoist.scm
@@ -0,0 +1,162 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+; Move nested procedures out to top level.  We move them all out, then merge
+; as many as possible back together (see merge.scm), and finally check to
+; see if there are any out-of-scope references.
+
+(define (hoist-nested-procedures forms)
+  (set! *hoist-index* 0)
+  (let loop ((forms forms) (done '()))
+    (if (null? forms)
+	(reverse done)
+	(loop (cdr forms)
+	      (let ((form (car forms)))
+		(if (eq? 'lambda (form-type form))
+		    (append (really-hoist-nested-procedures form)
+			    (cons form done))
+		    (cons form done)))))))
+
+(define (really-hoist-nested-procedures form)
+  (let ((top     (form-value form))
+	(lambdas (form-lambdas form))
+	(lambda-parent lambda-env)	; Rename a couple of handy fields
+	(lambda-kids lambda-block)
+	(new-forms '()))
+;    (format #t " ~S: ~S~%" (form-name form) lambdas)
+;    (if (eq? 'read-list (form-name form))
+;	(breakpoint "read-list"))
+    (receive (procs others)
+	(find-scoping lambdas
+		      lambda-env set-lambda-env!
+		      lambda-block set-lambda-block!)
+      (set-form-lambdas! form (cons top (non-proc-lambdas (lambda-kids top))))
+      (map (lambda (proc)
+	     (let ((var (replace-with-variable proc)))
+	       (make-hoist-form proc
+				var
+				(form-name form)
+				(non-proc-lambdas (lambda-kids proc)))))
+	   (filter (lambda (p)
+		     (not (eq? p top)))
+		   procs)))))
+
+(define (non-proc-lambdas lambdas)
+  (filter (lambda (l)
+	    (not (or (eq? 'proc (lambda-type l))
+		     (eq? 'known-proc (lambda-type l)))))
+	  lambdas))
+
+(define (make-hoist-form value var hoisted-from lambdas)
+  (let ((form (make-form var #f #f)))
+    (set-form-node! form value (cons value lambdas))
+    (set-form-type! form 'lambda)
+    (set-variable-flags! var
+			 (cons (cons 'hoisted hoisted-from)
+			       (variable-flags var)))
+    form))
+
+(define (replace-with-variable node)
+  (let ((var (make-hoist-variable node)))
+    (case (primop-id (call-primop (node-parent node)))
+      ((let)
+       (substitute-var-for-proc (node-parent node) node var))
+      ((letrec2)
+       (substitute-var-for-proc-in-letrec (node-parent node) node var))
+      (else
+       (move node
+	     (lambda (node)
+	       (make-reference-node var)))))
+    var))
+
+(define (make-hoist-variable node)
+  (cond ((bound-to-variable node)
+	 => (lambda (var)
+	      (make-global-variable (generate-hoist-name (variable-name var))
+				    (variable-type var))))
+	(else
+	 (let* ((vars (lambda-variables node))
+		(type (make-arrow-type (map variable-type (cdr vars))
+				       (variable-type (car vars))))
+		(id (generate-hoist-name (or (lambda-name node) 'hoist))))
+	   (make-global-variable id type)))))
+    
+(define (substitute-var-for-proc call node value-var)
+  (let ((proc (call-arg call 0)))
+    (really-substitute-var-for-proc proc call node value-var)
+    (if (null? (lambda-variables proc))
+        (replace-body call (detach-body (lambda-body proc))))))
+
+(define (substitute-var-for-proc-in-letrec call node value-var)
+  (let ((proc (node-parent call)))
+    (really-substitute-var-for-proc proc call node value-var)
+    (if (null? (cdr (lambda-variables proc)))
+        (replace-body (node-parent proc)
+		      (detach-body (lambda-body (call-arg call 0)))))))
+
+(define (really-substitute-var-for-proc binder call node value-var)
+  (let* ((index (node-index node))
+         (var (list-ref (lambda-variables binder)
+			(- (node-index node) 1))))
+    (walk-refs-safely
+     (lambda (ref)
+       (replace ref (make-reference-node value-var)))
+     var)
+    (remove-variable binder var)
+    (detach node)
+    (remove-call-arg call index)))
+
+(define *hoist-index* 0)
+
+(define (generate-hoist-name sym)
+  (let ((i *hoist-index*))
+    (set! *hoist-index* (+ i 1))
+    (concatenate-symbol sym "." i)))
+
+;----------------------------------------------------------------
+; Part 2: checking for variables moved out of scope.
+
+(define (check-hoisting forms)
+  (let ((forms (filter (lambda (form)
+			 (or (eq? 'merged (form-type form))
+			     (eq? 'lambda (form-type form))))
+		       forms)))
+    (for-each (lambda (form)
+		(cond ((flag-assq 'hoisted (variable-flags (form-var form)))
+		       => (lambda (p)
+			    (check-hoisted-form form (cdr p))))))
+	      forms)))
+
+(define (check-hoisted-form form hoisted-from)
+  (let ((vars (find-unbound-variables (form-value form) (form-head form))))
+    (if (not (null? vars))
+	(user-error "Procedure ~S in ~S is closed over: ~S~%"
+		    (form-name form)
+		    hoisted-from
+		    (map variable-name vars)))))
+
+(define (find-unbound-variables node form)
+  (let ((unbound '())
+	(mark (cons 0 0)))
+    (let label ((n node))
+      (cond ((lambda-node? n)
+	     (let ((flag (node-flag n)))
+	       (set-node-flag! n mark)
+	       (label (lambda-body n))
+	       (set-node-flag! n flag)))
+	    ((call-node? n)
+	     (let ((vec (call-args n)))
+	       (do ((i 0 (+ i 1)))
+		   ((= i (vector-length vec)))
+		 (label (vector-ref vec i)))))
+	    ((reference-node? n)
+	     (let* ((v (reference-variable n))
+		    (b (variable-binder v)))
+	       (cond ((and b
+			   (not (eq? mark (node-flag b)))
+			   (not (variable-flag v)))
+		      (set-variable-flag! v #t)
+		      (set! unbound (cons v unbound))))))))
+    (filter (lambda (v)
+	      (set-variable-flag! v #f)
+	      (not (eq? form (form-head (node-form (variable-binder v))))))
+	    unbound)))
diff --git a/ps-compiler/prescheme/infer-early.scm b/ps-compiler/prescheme/infer-early.scm
new file mode 100644
index 0000000..0d283a8
--- /dev/null
+++ b/ps-compiler/prescheme/infer-early.scm
@@ -0,0 +1,341 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+; Type checking nodes.
+
+; Entry point
+
+; Because NODE is not the car of a pair, this depends on lambdas not being
+; coerceable and literal nodes being coerced in place (instead of having a
+; call inserted).
+
+(define (infer-definition-type node name)
+  (set! *currently-checking* name)
+  (let ((res (cond ((literal-node? node)
+		    (infer-literal-type node name))
+		   ((lambda-node? node)
+		    (infer-type node 0))
+		   ((name-node? node)
+		    (get-global-type (binding-place (node-ref node 'binding))))
+		   (else
+		    (bug "definition value is not a value node ~S" node)))))
+    (set! *currently-checking* #f)
+    res))
+
+(define (infer-literal-type node name)
+  (let ((value (node-form node)))
+    (cond ((vector? value)
+	   (let ((uvar (make-uvar name -1)))
+	     (do ((i 0 (+ i 1)))
+		 ((>= i (vector-length value)))
+	       (unify! uvar (type-check-thing (vector-ref value i)) value))
+	     (make-pointer-type (maybe-follow-uvar uvar))))
+	  (else
+	   (infer-type node 0)))))
+
+(define (type-check-thing thing)
+  (if (variable? thing)
+      (get-package-variable-type thing)
+      (literal-value-type thing)))
+
+(define literal-operator (get-operator 'literal))
+
+(define (make-literal-node value)
+  (make-node literal-operator value))
+
+; Get the type of the variable - if it is a type-variable, then create a new
+; one and relate the two; if it is a polymorphic pattern, instantiate it.
+
+(define (get-package-variable-type var)
+  (let ((rep (variable-type var)))
+    (cond ((eq? rep type/undetermined)
+	   (let ((type (make-uvar (variable-name var) -1)))
+	     (set-variable-type! var type)
+	     (set-uvar-source! type var)
+	     type))
+	  ((type-scheme? rep)
+	   (instantiate-type-scheme rep -1))
+	  (else
+	   rep))))
+
+; Exported
+
+(define (get-variable-type var)
+  (let ((rep (variable-type var)))
+    (cond ((eq? rep type/undetermined)
+	   (bug "lexically bound variable ~S has no type" var))
+	  ((type-scheme? rep)
+	   (instantiate-type-scheme rep -1))
+	  (else
+	   rep))))
+
+;----------------------------------------------------------------
+
+(define (infer-type node depth)
+  (infer-any-type node depth #f))
+
+(define (infer-any-type node depth return?)
+  (let ((type ((operator-table-ref inference-rules (node-operator-id node))
+	       node
+	       depth
+	       return?)))
+    (set-node-type! node type)
+    (maybe-follow-uvar type)))
+
+(define inference-rules
+  (make-operator-table
+   (lambda (node depth return?)
+     (error "no type inference for node ~S" node))))
+
+(define (define-inference-rule name proc)
+  (operator-define! inference-rules name #f proc))
+
+(define-inference-rule 'literal
+  (lambda (node depth return?)
+    (infer-literal (node-form node) node)))
+
+(define-inference-rule 'quote
+  (lambda (node depth return?)
+    (infer-literal (cadr (node-form node)) node)))
+
+(define (infer-literal value node)
+  (literal-value-type value))
+
+(define (literal-value-type value)
+  (or (maybe-literal-value-type value)
+      (error "don't know type of literal ~S" value)))
+      
+(define (maybe-literal-value-type value)
+  (cond ((boolean? value)
+	 type/boolean)
+	((char? value)
+	 type/char)
+	((integer? value)
+	 type/integer)
+	((string? value)
+	 type/string)
+	(((structure-ref eval-node unspecific?) value)
+	 type/null)
+	((input-port? value)
+	 type/input-port)
+	((output-port? value)
+	 type/output-port)
+	((external-value? value)
+	 (external-value-type value))
+	((external-constant? value)
+         type/integer)
+	(else
+	 #f)))
+
+(define-inference-rule 'unspecific
+  (lambda (node depth return?)
+    type/null))
+
+(define-inference-rule 'lambda
+  (lambda (node depth return?)
+    (let* ((uid (unique-id))
+	   (exp (node-form node))
+	   (var-types (map (lambda (name-node)
+			     (initialize-name-node-type name-node uid depth))
+			   (cadr exp)))
+	   (result (infer-any-type (caddr exp) depth #t)))
+      ; stash the return type
+      (set-lambda-node-return-type! node result)
+      (make-arrow-type var-types result))))
+	
+; Create a new type variable for VAR.
+
+(define (initialize-name-node-type node uid depth)
+  (let ((uvar (make-uvar (node-form node) depth uid)))
+    (set-node-type! node uvar)
+    (set-uvar-source! uvar node)
+    uvar))
+
+; Get the type of the variable - if it is a type-variable, then create a new
+; one and relate the two; if it is a polymorphic pattern, instantiate it.
+; How to pass the source?
+
+(define-inference-rule 'name
+  (lambda (node depth return?)
+    (let ((type (if (node-ref node 'binding)
+		    (get-global-type (binding-place (node-ref node 'binding)))
+		    (node-type node))))
+      (if (not type)
+	  (bug "name node ~S has no type" node))
+      (if (type-scheme? type)
+	  (instantiate-type-scheme type depth)
+	  type))))
+
+(define-inference-rule 'primitive
+  (lambda (node depth return?)
+    (let ((type (get-global-type (cdr (node-form node)))))
+      (if (type-scheme? type)
+	  (instantiate-type-scheme type depth)
+	  type))))
+
+; If no type is present, create a type variable.
+
+(define (get-global-type value)
+  (if (location? value)
+      (literal-value-type (contents value))
+      (let ((has (maybe-follow-uvar (variable-type value))))
+	(cond ((not (eq? has type/undetermined))
+	       has)
+	      (else
+	       (let ((type (make-uvar (variable-name value) -1)))
+		 (set-variable-type! value type)
+		 (set-uvar-source! type value)
+		 type))))))
+
+(define-inference-rule 'set!
+  (lambda (node depth return?)
+    (let* ((exp (node-form node))
+	   (type (infer-type (caddr exp) depth))
+	   (binding (node-ref (cadr exp) 'binding)))
+      (if (not binding)
+	  (error "SET! on a local variable ~S" (schemify node)))
+      (unify! type (variable-type (binding-place binding)) node)
+      type/null)))
+
+(define-inference-rule 'call
+  (lambda (node depth return?)
+    (rule-for-calls (node-form node) node depth return?)))
+
+(define-inference-rule 'goto
+  (lambda (node depth return?)
+    (rule-for-calls (cdr (node-form node)) node depth return?)))
+
+(define (rule-for-calls proc+args node depth return?)
+  (let ((proc (car proc+args))
+	(args (cdr proc+args)))
+    (cond ((lambda-node? proc)
+	   (rule-for-let node depth proc args return?))
+	  ((primitive-node? proc)
+	   (rule-for-primitives node depth (node-form proc) args return?))
+	  (else
+	   (rule-for-unknown-calls node depth proc+args return?)))))
+
+(define name-node? (node-predicate 'name))
+(define lambda-node? (node-predicate 'lambda))
+(define literal-node? (node-predicate 'literal))
+(define primitive-node? (node-predicate 'primitive))
+
+(define (rule-for-let node depth proc args return?)
+  (let ((depth (+ depth 1))
+	(uid (unique-id))
+	(proc (node-form proc)))
+    (do ((names (cadr proc) (cdr names))
+	 (vals args (cdr vals)))
+	((null? names))
+      (let ((type (schemify-type (infer-type (car vals) depth) depth)))
+	(if (type-scheme? type)
+	    (set-node-type! (car names) type)
+	    (unify! (initialize-name-node-type (car names) uid depth)
+		    type
+		    node))))
+    (infer-any-type (caddr proc) depth return?)))
+
+(define (rule-for-primitives node depth primitive args return?)
+  ((primitive-inference-rule primitive)
+     args node depth return?))
+
+(define (rule-for-unknown-calls node depth proc+args return?)
+  (let ((proc-type (infer-type (car proc+args) depth))
+	(arg-types (infer-types (cdr proc+args) depth))
+	(return-type (if return?
+			 (make-tuple-uvar 'result depth)
+			 (make-uvar 'result depth))))
+    (unify! proc-type
+	    (make-arrow-type arg-types return-type)
+	    node)
+;    (if (= 244 (uvar-id return-type))
+;	(breakpoint "rule-for-unknown-calls"))
+    (maybe-follow-uvar return-type)))
+  
+(define (infer-types nodes depth)
+  (map (lambda (node)
+	 (infer-type node depth))
+       nodes))
+
+(define-inference-rule 'begin
+  (lambda (node depth return?)
+    (let loop ((exps (cdr (node-form node))) (type type/unit))
+      (if (null? exps)
+	  type
+	  (loop (cdr exps)
+		(infer-any-type (car exps)
+				depth
+				(or (not (null? (cdr exps)))
+				    return?)))))))
+
+; It would be nice if we could just try to unify the two arms and return
+; type/unit if we lost, but unification has side-effects.
+
+(define-inference-rule 'if
+  (lambda (node depth return?)
+    (let* ((args (cdr (node-form node)))
+	   (true-type (infer-any-type (cadr args) depth return?))
+	   (false-type (infer-any-type (caddr args) depth return?)))
+      (unify! (infer-type (car args) depth) type/boolean node)
+      (cond ((eq? true-type type/null)
+	     false-type)
+	    ((eq? false-type type/null)
+	     true-type)
+	    (else
+	     (unify! true-type false-type node)
+	     true-type)))))
+
+(define-inference-rule 'letrec
+  (lambda (node depth return?)
+    (let ((form (node-form node))
+	  (depth (+ depth 1))
+	  (uid (unique-id)))
+      (let ((names (map car (cadr form)))
+	    (vals (map cadr (cadr form))))
+	(for-each (lambda (name)
+		    (initialize-name-node-type name uid depth))
+		  names)
+	(do ((names names (cdr names))
+	     (vals vals (cdr vals)))
+	    ((null? names))
+	  (if (not (lambda-node? (car vals)))
+	      (error "LETREC value is not a LAMBDA: ~S" (schemify node)))
+	  (unify! (infer-type (car vals) depth)
+		  (node-type (car names))
+		  node))
+	(for-each (lambda (name)
+		    (let ((type (schemify-type (node-type name) depth)))
+		      (if (type-scheme? type)
+			  (set-node-type! name type))))
+		  names)
+	(infer-any-type (caddr form) depth return?)))))
+
+;--------------------------------------------------
+
+(define (node-type node)
+  (maybe-follow-uvar (node-ref node 'type)))
+
+(define (set-node-type! node type)
+  (node-set! node 'type type))
+
+(define (lambda-node-return-type node)
+  (node-ref node 'return-type))
+
+(define (set-lambda-node-return-type! node type)
+  (node-set! node 'return-type type))
+
+;--------------------------------------------------
+; Utility procedures used by the inferencers of the various primops.
+
+; Check that the INDEX'th argument of CALL has type TYPE.
+
+(define (check-arg-type args index type depth exp)
+  (if (null? args)
+      (begin
+	(format #t "Wrong number of arguments in ~S~% " (schemify exp))
+	(if *currently-checking*
+	    (format #t "~% while reconstructing the type of '~S'" *currently-checking*))
+	(error "type problem")))
+  (unify! (infer-type (list-ref args index) depth)
+	  type
+	  exp))
+
diff --git a/ps-compiler/prescheme/inference.scm b/ps-compiler/prescheme/inference.scm
new file mode 100644
index 0000000..bf76912
--- /dev/null
+++ b/ps-compiler/prescheme/inference.scm
@@ -0,0 +1,94 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+; Type Inference
+;
+; The entry points to the inferencer are:
+;
+; (unify! type1 type2 context)
+;   Unify TYPE1 and TYPE2.  CONTEXT is used to provide user feedback when type
+;   errors are detected.
+;
+; (make-uvar prefix depth . maybe-id)
+;   Makes a new type variable.  PREFIX is a symbol, DEPTH is the current type
+;   depth (used for polymorphism), and MAYBE-ID is an optional unique
+;   integer.
+;
+; (schemify-type type depth)
+;   Make TYPE polymorphic in any variables bound at DEPTH.
+;
+; (instantiate-type-scheme scheme depth)
+;   Return an instantiation of SCHEME at DEPTH.
+;
+; (reset-inference!)
+;   Clear various global variables (to be replaced with fluids at some point)
+
+
+(define (unify! type1 type2 context)
+  (cond ((really-unify! type1 type2)
+	 => (lambda (error-thunk)
+	      (unify-lost error-thunk type1 type2 context)))))
+
+(define *currently-checking* #f)
+(define *current-top-exp* #f)
+
+(define (unify-lost error-thunk type1 type2 context)
+  (cond ((eq? context 'simplifying)
+	 (bug "unification error while instantiating an integrable procedure"))
+	((eq? context 'make-monomorphic)
+	 #f)
+	(else
+	 (user-type-error-message error-thunk type1 type2 context))))
+
+(define (user-type-error-message error-thunk type1 type2 context)
+  (format #t "Type error in ~S~% " (schemify context))
+  (error-thunk)
+  (if *currently-checking*
+      (begin
+	(format #t "~% while reconstructing the type of~%  ")
+	(*currently-checking* (current-output-port))))
+  (error "type problem"))
+
+(define (really-unify! p1 p2)
+  (let ((p1 (maybe-follow-uvar p1))    ; get the current value of P1
+	(p2 (maybe-follow-uvar p2)))   ; get the current value of P2
+    (cond ((or (eq? p1 p2)
+	       (eq? p1 type/null)
+	       (eq? p2 type/null))
+	   #f)
+	  ((uvar? p1)
+	   (bind-uvar! p1 p2))
+	  ((uvar? p2)
+	   (bind-uvar! p2 p1))
+	  ((other-type? p1)
+	   (if (and (other-type? p2)
+		    (eq? (other-type-kind p1) (other-type-kind p2))
+		    (= (length (other-type-subtypes p1))
+		       (length (other-type-subtypes p2))))
+	       (unify-lists! (other-type-subtypes p1)
+			     (other-type-subtypes p2))
+	       (mismatch-failure p1 p2)))
+	  (else
+	   (mismatch-failure p1 p2)))))
+
+(define (mismatch-failure t1 t2)
+  (lambda ()
+    (format #t "type mismatch~% ")
+    (display-type t1 (current-output-port))
+    (format #t "~% ")
+    (display-type t2 (current-output-port))))
+
+(define (unify-lists! l1 l2)
+  (let loop ((l1 l1) (l2 l2))
+    (if (null? l1)
+	#f
+	(or (really-unify! (car l1) (car l2))
+	    (loop (cdr l1) (cdr l2))))))
+
+(define (type-conflict message . stuff)
+  (apply breakpoint message stuff))
+
+; For debugging
+(define (uvar-name uvar)
+  (concatenate-symbol (uvar-prefix uvar) "." (uvar-id uvar)))
+
diff --git a/ps-compiler/prescheme/interfaces.scm b/ps-compiler/prescheme/interfaces.scm
new file mode 100644
index 0000000..0a91a57
--- /dev/null
+++ b/ps-compiler/prescheme/interfaces.scm
@@ -0,0 +1,215 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+(define-interface ps-primop-interface
+  (export get-prescheme-primop
+          (define-scheme-primop :syntax)
+          (define-polymorphic-scheme-primop :syntax)
+          (define-nonsimple-scheme-primop :syntax)
+          (define-scheme-cond-primop :syntax)
+
+	  prescheme-integer-size
+	  lshr))
+
+(define-interface ps-c-primop-interface
+  (export simple-c-primop?
+          primop-generate-c
+          (define-c-generator :syntax)))
+
+(define-interface ps-type-interface
+  (export ;type/int7u
+          ;type/int8
+          ;type/int8u
+          type/integer
+          type/float
+	  type/char
+	  type/address
+
+          type/null
+          type/unit
+          type/boolean
+          type/undetermined
+          type/input-port
+          type/output-port
+
+          type/unknown
+          type/string
+
+          other-type?
+          other-type-kind
+          other-type-subtypes
+          make-other-type
+
+          base-type?
+          base-type-name
+	  base-type-uid
+	  make-atomic-type
+
+          make-arrow-type
+          arrow-type?
+          arrow-type-result
+          arrow-type-args
+
+          make-pointer-type
+          pointer-type?
+          pointer-type-to
+
+	  make-tuple-type
+	  tuple-type?
+	  tuple-type-types
+
+	  record-type?
+
+          lookup-type
+
+          type-scheme?
+          schemify-type
+          instantiate-type-scheme
+          copy-type
+          type-scheme-type
+          make-nonpolymorphic!
+
+          type-scheme-free-uvars           ; for error messages
+;          type-scheme-lattice-uvars
+;          type-scheme-type
+
+          type-eq?
+;          type>
+;          type>=
+
+;          lattice-type?
+
+	  expand-type-spec
+
+          finalize-type
+
+          display-type
+
+	  make-base-type-table
+          ))
+
+(define-interface type-variable-interface
+  (export make-uvar
+	  make-tuple-uvar
+          uvar?
+          maybe-follow-uvar
+          uvar-source set-uvar-source!
+
+          reset-type-vars!
+
+          uvar-binding set-uvar-binding!
+          uvar-prefix
+          uvar-id
+	  uvar-temp set-uvar-temp!
+
+          bind-uvar!
+
+          unique-id
+          ))
+
+(define-interface record-type-interface
+  (export reset-record-data!
+	  all-record-types
+	  get-record-type
+	  record-type-name
+	  record-type-fields
+	  get-record-type-field
+	  record-field-record-type
+	  record-field-name
+	  record-field-type))
+
+(define-interface inference-interface
+  (export infer-definition-type
+	  get-package-variable-type
+	  get-variable-type
+          ;add-type-coercions
+	  node-type
+	  lambda-node-return-type))
+
+(define-interface inference-internal-interface
+  (export unify!
+	  infer-type infer-types
+          check-arg-type
+          literal-value-type
+          ))
+
+(define-interface form-interface
+  (export make-form
+          form?
+          form-value
+          set-form-value!
+	  form-value-type
+	  set-form-value-type!
+	  node-form
+          set-form-node!
+          set-form-integrate!
+          set-form-exported?!
+	  form-node
+          form-var
+          form-exported?
+          form-type
+          set-form-type!
+          form-free set-form-free!
+	  suspend-form-use!
+	  use-this-form!
+	  also-use-this-form!
+	  set-form-lambdas!
+          form-lambdas
+          form-name
+          form-merge set-form-merge!
+          form-providers set-form-providers!
+          form-clients set-form-clients!
+	  form-shadowed set-form-shadowed!
+            
+	  variable-set!? note-variable-set!!
+	  make-form-unused!
+          variable->form
+          maybe-variable->form
+            
+          ; high level stuff
+          sort-forms
+          expand-and-simplify-form
+          remove-unreferenced-forms
+          integrate-stob-form
+          resimplify-form
+          ))
+
+(define-interface linking-interface
+  (export package-specs->packages+exports
+	  package-source
+          define-prescheme!
+	  prescheme-compiler-env
+          ))
+
+(define-interface c-internal-interface
+  (export c-assignment
+          indent-to
+          c-argument-var
+          form-tail-called?
+          *doing-tail-called-procedure?*
+          merged-procedure-reference
+          goto-protocol?
+          c-ify
+          c-value
+          form-value
+          form-name
+          form-c-name
+          form-type
+          c-assign-to-variable
+          write-c-identifier
+          write-value-list
+	  write-value-list-with-extras
+          write-value+result-var-list
+          form-return-count
+          set-form-return-count!
+          simple-c-primop
+          c-variable
+          *current-merged-procedure*
+          *extra-tail-call-args*
+          write-c-block
+          write-c-coercion
+          no-value-node?
+          display-c-type
+	  add-c-type-declaration!
+	  note-jump-generated!
+          ))
+
diff --git a/ps-compiler/prescheme/linking.scm b/ps-compiler/prescheme/linking.scm
new file mode 100644
index 0000000..677f004
--- /dev/null
+++ b/ps-compiler/prescheme/linking.scm
@@ -0,0 +1,236 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+; This file has the Pre-Scheme compiler's code for dealing with the
+; Scheme 48's module system.
+
+; FILES is a list of files that contain structure definitions, including
+; a definition for NAME.  The files are loaded into a config package
+; containing:
+;   - the procedures and macros for defining structures and interfaces
+;   - a Pre-Scheme structure (called PRESCHEME)
+;   - a ps-memory structure
+;   - a ps-receive structure
+;   - the STRUCTURE-REFS structure
+; We then return:
+;   1. a list of the packages required to implement the named structures
+;   2. a list of the names exported by the named structures
+;   3. a procedure that for looking up names defined in packages in the
+;      config package (this is used to map user directives to their targets)
+
+(define (package-specs->packages+exports struct-names files)
+  (let ((config (make-very-simple-package 'config (list defpackage)))
+	(old-config ((structure-ref package-commands-internal config-package))))
+    (environment-define! config 'prescheme prescheme)
+    (environment-define! config 'ps-memory ps-memory)
+    (environment-define! config 'ps-receive ps-receive)
+    (environment-define! config 'ps-record-types ps-record-types)
+    (environment-define! config 'structure-refs structure-refs)
+    (environment-define! config ':syntax (structure-ref meta-types syntax-type))
+    (set-reflective-tower-maker! config (get-reflective-tower-maker old-config))
+    (let-fluids (structure-ref packages-internal $get-location)
+		get-variable
+		(structure-ref reading-forms $note-file-package)
+		(lambda (filename package) (values))
+      (lambda () 
+	(for-each (lambda (file)
+		    (load file config))
+		  files)))
+    (values (collect-packages (map (lambda (name)
+				     (environment-ref config name))
+				   struct-names)
+			      (lambda (package)
+				#t))
+	    (let ((names '()))
+	      (for-each (lambda (struct-name)
+			  (let ((my-names '()))
+			    (for-each-declaration
+			     (lambda (name type)
+			       (set! my-names (cons name my-names)))
+			     (structure-interface (environment-ref config struct-name)))
+			    (set! names (cons (cons struct-name my-names) names))))
+			struct-names)
+	      names)
+	    (make-lookup config))))
+
+; This creates new variables as needed for packages.
+
+(define (get-variable package name)
+  ;(format #t "Making variable ~S for ~S~%" name package)
+  ((structure-ref variable make-global-variable)
+     name
+     (structure-ref ps-types type/unknown)))
+
+; Return something that will find the binding of ID in the package belonging
+; to the structure PACKAGE-ID in the CONFIG package.
+
+(define (make-lookup config)
+  (lambda (package-id id)
+    (let ((binding (package-lookup config package-id)))
+      (if (and (binding? binding)
+	       (location? (binding-place binding))
+	       (structure? (contents (binding-place binding))))
+	  (let* ((package (structure-package
+			   (contents (binding-place binding))))
+		 (binding (package-lookup package id)))
+	    (if (binding? binding)
+		(binding-place binding)
+		#f))
+	  #f))))
+	       
+;----------------------------------------------------------------
+; Handy packages and package making stuff.
+
+(define defpackage     (structure-ref built-in-structures defpackage))
+(define structure-refs (structure-ref built-in-structures structure-refs))
+(define scheme         (structure-ref built-in-structures scheme))
+
+(define (make-env-for-syntax-promise . structures)
+  (make-reflective-tower eval structures 'prescheme-linking))
+
+(define (make-very-simple-package name opens)
+  (make-simple-package opens
+		       eval
+		       (make-env-for-syntax-promise scheme)
+		       name))
+
+(define (get-reflective-tower-maker p)
+  (environment-ref p (string->symbol ".make-reflective-tower.")))
+
+;----------------------------------------------------------------
+; The following stuff is used to define the DEFINE-RECORD-TYPE macro.
+; We produce a structure that exports EXPAND-DEFINE-RECORD-TYPE.  The
+; base package then includes that structure in its FOR-SYNTAX package.
+
+(define defrecord-for-syntax-package
+  (make-very-simple-package 'defrecord-for-syntax-package '()))
+
+(define defrecord-for-syntax-structure
+  (make-structure defrecord-for-syntax-package
+		  (lambda () (export expand-define-record-type))
+		  'defrecord-for-syntax-structure))
+
+(define (define-for-syntax-value id value)
+  (let ((loc (make-new-location defrecord-for-syntax-package id)))
+    (set-contents! loc value)
+    (package-define! defrecord-for-syntax-package
+		     id
+		     (structure-ref meta-types usual-variable-type)
+		     loc
+		     #f)))
+
+(define-for-syntax-value 'expand-define-record-type expand-define-record-type)
+
+;----------------------------------------------------------------
+; BASE-PACKAGE contains all of the primitives, syntax, etc. for Pre-Scheme
+
+(define (prescheme-unbound package name)
+  (bug "~S has no binding in package ~S" name package))
+
+(define base-package
+;  (let-fluid (structure-ref packages-internal $get-location) prescheme-unbound
+;    (lambda () ))
+  (make-simple-package '()
+		       eval
+		       (make-env-for-syntax-promise
+			  scheme
+			  defrecord-for-syntax-structure)
+		       'base-package))
+
+; Add the operators.
+
+(let ((syntax-type (structure-ref meta-types syntax-type)))
+  (for-each (lambda (id)
+	      (package-define! base-package
+			       id
+			       syntax-type
+			       #f
+			       (get-operator id syntax-type)))
+	    '(if begin lambda letrec quote set!
+		 define define-syntax let-syntax
+		 goto real-external)))  ; special for Prescheme
+
+; Add the usual macros.
+
+(let ((syntax-type (structure-ref meta-types syntax-type)))
+  (for-each (lambda (name)
+	      (package-define! base-package
+			       name
+			       syntax-type
+			       #f
+			       (make-transform
+			         (usual-transform name)
+				 base-package
+				 (structure-ref meta-types syntax-type)
+				 `(usual-transform ',name)
+				 name)))
+	    '(and cond do let let* or quasiquote syntax-rules))) ; delay
+
+; Plus whatever primitives are wanted.
+
+(define (define-prescheme! name location static)
+  (package-define! base-package
+		   name
+		   (structure-ref meta-types usual-variable-type)
+		   location
+		   static))
+
+; Copy over the enumeration macros and the ERRORS enumeration.
+
+(define (import-syntax! package-id name)
+  (let ((config ((structure-ref package-commands-internal config-package)))
+	(syntax-type (structure-ref meta-types syntax-type)))
+    (let ((binding (structure-lookup (environment-ref config package-id)
+				     name
+				     #t)))
+      (package-define! base-package
+		       name
+		       syntax-type
+		       (binding-place binding)
+		       (binding-static binding)))))
+
+(import-syntax! 'enumerated 'define-enumeration)
+(import-syntax! 'enumerated 'enum)
+(import-syntax! 'enumerated 'name->enumerand)
+(import-syntax! 'enumerated 'enumerand->name)
+(import-syntax! 'prescheme  'errors)
+(import-syntax! 'prescheme  'define-external-enumeration)
+
+; define still more syntax
+
+(load "prescheme/ps-syntax.scm" base-package)
+
+(eval '(define-syntax define-record-type expand-define-record-type)
+      base-package)
+
+;----------------------------------------------------------------
+; Make the Pre-Scheme structure and related structures
+
+(define (get-interface name)
+  (environment-ref ((structure-ref package-commands-internal config-package))
+		   name))
+
+(define prescheme
+  (make-structure base-package
+		  (lambda () (get-interface 'prescheme-interface))
+		  'prescheme))
+
+(define ps-memory
+  (make-structure base-package
+		  (lambda () (get-interface 'ps-memory-interface)) 
+		  'ps-memory))
+
+(define ps-receive
+  (make-structure base-package
+		  (lambda () (get-interface 'ps-receive-interface)) 
+		  'ps-receive))
+
+(define ps-record-types
+  (make-structure base-package
+                  (lambda () (export (define-record-type :syntax)))
+                  'ps-record-types))
+
+; and a handy environment
+
+(define prescheme-compiler-env
+  (package->environment base-package))
+
diff --git a/ps-compiler/prescheme/merge.scm b/ps-compiler/prescheme/merge.scm
new file mode 100644
index 0000000..806f71a
--- /dev/null
+++ b/ps-compiler/prescheme/merge.scm
@@ -0,0 +1,296 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+; This code determines which procedures are called from one other form, and
+; thus can be compiled as part of that form and called with a `goto' instead
+; of a normal procedure call.  This saves much of the overhead of a normal
+; procedure call.
+;
+; The procedures to be merged are annotated; no code is changed.
+
+(define-subrecord form form-merge form-merge
+  ((head)           ; self or the form into which this one will be merged
+   )
+  (
+   (status #f)      ; one of #F, DO-NOT-MERGE, MERGED
+   tail-clients     ; forms that call this one tail-recursively, this is an
+                    ; a-list of forms and reference nodes
+   (tail-providers '()) ; forms that are used by this one, this is a simple list
+   (merged '())     ; forms merged with this one
+   (return-count 0) ; how many returns have been generated so far
+   temp             ; handy utility field
+   ))
+
+; Two procedures for letting the user know what is going on.
+
+(define (show-merges form)
+  (let ((merges (form-merged form)))
+    (if (not (null? merges))
+	(format #t " ~S: ~S~%" (form-name form) (map form-name merges)))))
+
+(define (show-providers form)
+  (cond ((eq? (form-type form) 'lambda)
+	 (format #t "~S ~A~%"
+		 (form-name form)
+		 (if (form-exported? form) " (exported)" ""))
+	 (cond ((or (not (null? (form-providers form)))
+		    (not (null? (form-tail-providers form))))
+		(format #t "  ~S~%  ~S~%"
+			(map form-name (form-providers form))
+			(map form-name (form-tail-providers form))))))))
+
+; Note that OTHERS should be merged with FORM.
+
+(define (do-merge form others)
+  (let ((form (form-head form))
+	(secondary (apply append (map form-merged others))))
+    (set-form-merged! form (append others
+				   secondary
+				   (form-merged form)))
+    (for-each (lambda (f)
+		(set-form-head! f form))
+	      secondary)
+    (for-each (lambda (f)
+		(set-form-head! f form)
+		(set-form-status! f 'merged)
+		(set-form-type! f 'merged)
+		(set-form-merged! f '()))
+	      others)))
+
+; Returns the merged form, if any, to which NODE is a reference.
+
+(define (merged-procedure-reference node)
+  (cond ((and (reference-node? node)
+	      (maybe-variable->form (reference-variable node)))
+	 => (lambda (form)
+	      (if (eq? 'merged (form-type form))
+		  form
+		  #f)))
+	(else #f)))
+
+; Is FORM ever tail called?
+
+(define (form-tail-called? form)
+  (and (or (eq? 'lambda (form-type form))
+	   (eq? 'merged (form-type form)))
+       (memq? 'tail-called (variable-flags (form-var form)))))
+
+; Annotate FORM if it is in fact called tail-recursively anywhere.
+
+(define (note-tail-called-procedure form)
+  (if (and (eq? 'lambda (form-type form))
+	   (or (any (lambda (r)
+		      (used-as-label? r))
+		    (variable-refs (form-var form)))
+	       (eq? 'tail-called (lambda-protocol (form-value form)))))
+      (set-variable-flags! (form-var form)
+			   (cons 'tail-called
+				 (variable-flags (form-var form))))))
+
+(define (used-as-label? node)
+  (and (node? (node-parent node))
+       (goto-call? (node-parent node))
+       (= 1 (node-index node))))
+
+;------------------------------------------------------------
+; Entry point.
+;
+; First marks the tail-called procedures and adds the MERGE slots to the
+; forms.  The C code generator expects FORM-MERGED to work, even if no
+; actual merging was done.
+;
+; Three steps:
+;  Find the call graph.
+;  Merge the tail-called forms.
+;  Merge the non-tail-called forms. 
+
+(define *merge-forms?* #t)
+
+(define (merge-forms forms)
+  (for-each (lambda (f)
+	      (note-tail-called-procedure f)
+	      (set-form-merge! f (form-merge-maker f))
+	      (set-form-providers! f '()))
+	    forms)
+  (if *merge-forms?*
+      (let ((mergable-forms (filter determine-merger-graph forms)))
+	(format #t "Call Graph:~%<procedure name>~%")
+	(format #t "  <called non-tail-recursively>~%")
+	(format #t "  <called tail-recursively>~%")
+	(for-each show-providers forms)
+	(format #t "Merging forms~%")
+	(receive (tail other)
+	    (partition-list (lambda (f) (null? (form-clients f)))
+			    mergable-forms)
+	  (merge-tail-forms tail)
+	  (for-each merge-non-tail-forms forms)
+	  (for-each show-merges forms)
+	  (values)))))
+
+; The only forms that can be merged are those that:
+;  are lambdas,
+;  all uses are calls,
+;  are not exported, and
+;  every loop containing a non-tail-recursive call must contain a call to
+;  at least one non-merged procedure.
+; 
+; This code doesn't use the last criterion.  Instead it makes sure that each
+; procedure is called exclusively tail-recursively or non-tail-recursively
+; and doesn't allow non-tail-recursion in loops at all.
+
+(define (determine-merger-graph form)
+  (cond ((and (eq? 'lambda (form-type form))
+	      (really-determine-merger-graph form)
+	      (not (form-exported? form))
+	      (or (null? (form-clients form))
+		  (null? (form-tail-clients form))))
+	 #t)
+	(else
+	 (set-form-status! form 'do-not-merge)
+	 #f)))
+
+; Loop down the references to FORM's variable adding FORM to the providers
+; lists of the forms that reference the variable, and adding those forms
+; to FORM's clients lists.  OKAY? is #T if all references are calls.
+
+; The full usage graph is needed, even if there are uses of the form's value
+; that are not calls.
+
+(define (really-determine-merger-graph form)
+  (let loop ((refs (variable-refs (form-var form)))
+	     (clients '()) (tail-clients '()) (okay? #t))
+    (cond ((null? refs)
+	   (set-form-clients! form clients)
+	   (set-form-tail-clients! form tail-clients)
+	   okay?)
+	  (else
+	   (let* ((r (car refs))
+		  (f (node-form (car refs))))
+ 	     (if (and (called-node? r)
+ 		      (or (calls-this-primop? (node-parent r) 'tail-call)
+ 			  (calls-this-primop? (node-parent r) 'unknown-tail-call)))
+ 		 (loop (cdr refs)
+ 		       clients
+ 		       (add-to-client-list tail-clients r form f
+ 					   form-tail-providers
+ 					   set-form-tail-providers!)
+ 		       okay?)
+ 		 (loop (cdr refs)
+ 		       (add-to-client-list clients r form f
+ 					   form-providers
+ 					   set-form-providers!)
+ 		       tail-clients
+ 		       (and okay? (called-node? r)))))))))
+
+(define (add-to-client-list client-list ref form f getter setter)
+  (cond ((assq f client-list)
+	 => (lambda (p)
+	      (set-cdr! p (cons ref (cdr p)))
+	      client-list))
+	(else
+	 (setter f (cons form (getter f)))
+	 (cons (list f ref) client-list))))
+
+; These forms are non-exported procedures that are always tail-called.
+; Strongly connected components of the call graph that have a single
+; entry point, whether in the component or not, are merged.
+; This depends on STRONGLY-CONNECTED-COMPONENTS returning the components
+; in a reverse topologically sorted order (which it does).
+
+(define (merge-tail-forms forms)
+  (for-each merge-tail-loop
+	    (reverse (strongly-connected-components
+		      forms
+		      (lambda (f)
+			(filter (lambda (f) (memq? f forms))
+				(map car (form-tail-clients f))))
+		      form-temp
+		      set-form-temp!))))
+
+; ENTRIES are the forms in the loop that are called from outside.
+; FORMS is used as a unique identifier here.
+
+(define (merge-tail-loop forms)
+  (for-each (lambda (f) (set-form-temp! f forms)) forms)
+  (receive (entries other)
+      (partition-list (lambda (f)
+			(any? (lambda (p)
+				(not (eq? forms
+					  (form-temp (car p)))))
+			      (form-tail-clients f)))
+		      forms)
+    (cond ((single-outside-client (if (null? entries)
+				      other
+				      entries)
+				  forms)
+	   => (lambda (f) (do-merge f forms)))
+	  ((and (not (null? entries))
+		(null? (cdr entries))
+		(not (null? other)))
+	   (do-merge (car entries) other)))
+    (for-each (lambda (f) (set-form-temp! f #f)) forms)))
+
+; This checks to see if all non-FLAGged clients of ENTRIES are in
+; fact a single form, and then returns that form.
+; Forms that have already been merged into another form are treated as that
+; other form (by using FORM-HEAD).
+
+(define (single-outside-client entries flag)
+  (let loop ((entries entries) (form #f))
+    (if (null? entries)
+	form
+	(let loop2 ((clients (form-tail-clients (car entries))) (form form))
+	  (cond ((null? clients)
+		 (loop (cdr entries) form))
+		((eq? (form-temp (caar clients)) flag)
+		 (loop2 (cdr clients) form))
+		((not form)
+		 (loop2 (cdr clients) (form-head (caar clients))))
+		((eq? (form-head (caar clients)) form)
+		 (loop2 (cdr clients) form))
+		(else
+		 #f))))))
+
+; Merge the forms used by FORM into it if possible.
+
+(define (merge-non-tail-forms form)
+  (for-each (lambda (f)
+	      (maybe-merge-non-tail-form f (form-head form)))
+	    (form-providers form)))
+
+; If FORM is not INTO, has not been merged before, and is only used by
+; INTO, then merge FORM into INTO and recursively check the forms used
+; by FORM.
+
+(define (maybe-merge-non-tail-form form into)
+  (cond ((and (not (eq? form into))
+	      (not (form-status form))
+	      (every? (lambda (p)
+			(eq? (form-head (car p)) into))
+		      (form-clients form)))
+	 (do-merge into (list form))
+	 (for-each tail-call->call
+		   (variable-refs (form-var form)))
+	 (for-each tail-call->call
+		   (variable-refs (car (lambda-variables (form-node form)))))
+	 (for-each (lambda (f)
+		     (maybe-merge-non-tail-form f into))
+		   (form-providers form)))))
+
+; Replace tail calls with calls to make the code generator's job easier.
+; The user didn't say that these calls had to be tail-recursive.
+
+(define (tail-call->call ref)
+  (let ((call (node-parent ref)))
+    (if (or (calls-this-primop? call 'tail-call)
+	    (calls-this-primop? call 'unknown-tail-call))
+	(let ((type (arrow-type-result (node-type (call-arg call 1)))))
+	  (move (call-arg call 0)
+		(lambda (cont)
+		  (let-nodes ((new-cont ((v type)) (return 0 cont (* v))))
+		    new-cont)))
+	  (set-call-exits! call 1)
+	  (set-call-primop! call
+			    (get-primop (if (calls-this-primop? call 'tail-call)
+					    (enum primop call)
+					    (enum primop unknown-call))))))))
+  
\ No newline at end of file
diff --git a/ps-compiler/prescheme/node-type.scm b/ps-compiler/prescheme/node-type.scm
new file mode 100644
index 0000000..f5356c3
--- /dev/null
+++ b/ps-compiler/prescheme/node-type.scm
@@ -0,0 +1,78 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+; Types and nodes together
+
+; Instantiate TYPE and replace the types in NODE with their corresponding
+; value.  LOCATION is where NODE will be applied, and is used to get the actual
+; types of the arguments.
+
+(define (instantiate-type&value type node location)
+  (let ((has (instantiate-type-scheme type
+				      -1
+				      (lambda () (fix-types node))))
+	(wants (call->proc-type (node-parent location))))
+    (identity (unify! has wants 'simplifying))))
+;	  (format #t "~%Reconstructing ")
+;	  (pp-cps call)
+;	  (format #t " has   ~S~% wants ~S~%"
+;		  (instantiate has)
+;		  (instantiate wants))
+;	  (breakpoint "reconstructing ~S" call)
+;	  (unify! has wants 'simplifying)
+
+; This is used to replace all references in NODE to polymorphic type variables
+; with the current value of the type variable.
+; Youch!  Very inefficient - may make many copies of the same type.
+
+(define (fix-types node)
+  (let label ((node node))
+    (case (node-variant node)
+      ((lambda)
+       (for-each fix-variable (lambda-variables node))
+       (label (lambda-body node)))
+      ((call)
+       (walk-vector label (call-args node)))
+      ((literal)
+       (let ((value (literal-value node)))
+	 (if (or (uvar? value)
+		 (other-type? value))
+	     (set-literal-value! node (copy-type value))))))))
+
+(define (fix-variable var)
+  (set-variable-type! var (copy-type (variable-type var))))
+
+(define (call->proc-type call)
+  (let ((end (if (or (calls-this-primop? call 'call)
+		     (calls-this-primop? call 'tail-call))
+		 2        ; no protocol to ignore
+		 3)))     ; protocol to ignore
+    (make-arrow-type (do ((i (- (vector-length (call-args call)) 1) (- i 1))
+			  (ts '() (cons (maybe-instantiate
+					 (node-type (call-arg call i)))
+					ts)))
+			 ((< i end)
+			  ts))
+		     (let ((cont (call-arg call 0)))
+		       (if (reference-node? cont)
+			   (variable-type (reference-variable cont))
+			   (make-tuple-type (map variable-type
+						 (lambda-variables cont))))))))
+
+(define (maybe-instantiate type)
+  (if (type-scheme? type)
+      (instantiate-type-scheme type -1)
+      type))
+
+(define (make-monomorphic! var)
+  (let ((type (type-scheme-type (variable-type var))))
+    (for-each (lambda (ref)
+		(if (not (called-node? ref))
+		    (error
+		     "polymorphic procedure ~S used as value, cannot be made monomorphic"
+		     (variable-name var))
+		    (unify! type
+			    (call->proc-type (node-parent ref))
+			    'make-monomorphic!)))
+	      (variable-refs var))
+    (set-variable-type! var type)))
\ No newline at end of file
diff --git a/ps-compiler/prescheme/package-defs.scm b/ps-compiler/prescheme/package-defs.scm
new file mode 100644
index 0000000..fbdf27f
--- /dev/null
+++ b/ps-compiler/prescheme/package-defs.scm
@@ -0,0 +1,310 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+; Pre-Scheme packages
+
+; Everything else
+
+(define-structures ((prescheme-compiler (export)))
+  (open scheme big-scheme conditions comp-util structure-refs
+	prescheme-front-end prescheme-display
+	parameters
+	node
+	front-debug forms
+	ps-types
+	type-variables
+	c
+	structure-refs
+	primop-data
+	c-primop-data
+	jump                 ;find-jump-procs procs->jumps 
+	record-types         ;reset-record-data!
+	node-types
+	front                ;simplify-all
+	simplify)            ;simplify-node
+  (files top))
+
+(define-structures ((prescheme-display (export display-forms-as-scheme)))
+  (open scheme big-scheme
+	structure-refs
+	names
+	bindings		;binding-place
+	nodes
+	variable primop external-values ps-primitives
+	flatten-internal	;generated-top-variable?
+	external-constants)
+  (access forms)		;form-value form-var
+  (files display))
+
+(define-structures ((protocol (export normal-protocol
+				      goto-protocol
+				      goto-protocol?)))
+  (open scheme big-scheme comp-util set-parameters ps-primops ps-types node)
+  (files spec))
+
+(define-structures ((prescheme-front-end (export prescheme-front-end)))
+  (open scheme big-scheme comp-util structure-refs
+	linking expand flatten forms
+	ps-types inference
+	variable
+	primitive-data
+	primop-data
+	inference-internal  ; unify!
+	type-variables)     ; reset-type-vars!
+  (access nodes		    ; node? schemify
+	  node              ; reset-node-id
+	  record-types)     ; reset-record-types!    
+  (files front-end))
+
+(define-structures ((forms form-interface))
+  (open scheme big-scheme comp-util node expand defrecord
+	node-vector queues to-cps
+	structure-refs
+	eval-node         ; closure stuff
+	ps-primops        ; get-prescheme-primop
+	simplify-internal ; simplify-node simplify-args
+	front             ; simplify-all
+	ps-types          ; type/undetermined
+	type-variables    ; maybe-follow-uvar
+	node-types)       ; instantiate-type&value
+  (access nodes)          ; node-predicate
+  (files form))
+
+; Translating Scheme into evaluated nodes
+
+(define-structures ((expand (export scan-packages)))
+  (open scheme big-scheme comp-util structure-refs
+	variable
+	bindings nodes
+	ps-primitives   ;eval-primitive
+	eval-node       ;eval-node
+	scan-package	;package-source
+	locations
+	util		;fold
+	syntactic)
+  (access packages)     ;package->environment
+  (files expand))
+
+; Eval and type information on Pre-Scheme primitives
+
+(define-structures ((ps-primitives (export primitive?
+					   make-primitive
+					   eval-primitive
+					   primitive-id
+					   primitive-source
+					   primitive-expander
+					   primitive-expands-in-place?
+					   primitive-inference-rule)))
+  (open scheme big-scheme comp-util defrecord)
+  (files primitive))
+
+(define-structures ((primitive-data (export)))
+  (open scheme big-scheme comp-util ps-primitives
+	bindings nodes
+	ascii structure-refs
+	ps-primops		;get-prescheme-primop
+	linking			;define-prescheme!
+	inference-internal	;check-arg-type
+	type-variables		;make-arith-op-uvar
+	record-types
+	prescheme ps-memory
+	ps-types external-constants external-values
+	locations
+	eval-node)  ; closure?  (to keep them from being made immutable)
+  (access variable)   ; variable-name
+  (files (primop scm-scheme)
+	 (primop scm-arith)
+	 (primop scm-memory)
+	 (primop scm-record)))
+
+(define-structures ((eval-node (export eval-node
+				       closure? closure-node closure-env
+				       make-top-level-closure
+				       closure-temp set-closure-temp!
+				       apply-closure
+				       unspecific? constant?)))
+  (open scheme define-record-types
+	nodes
+	ps-types		;expand-type-spec
+	external-values
+	external-constants	;external-constant?
+	signals			;error
+	util)			;unspecific
+  (files eval))
+
+; Reducing closures and data structures to simple definitions
+
+(define-structures ((flatten (export flatten-definitions))
+		    (flatten-internal (export generated-top-variable?)))
+  (open scheme big-scheme comp-util defrecord
+	structure-refs
+	bindings nodes
+	variable
+	eval-node 	;closure stuff, constant?
+	ps-primitives	;primitive stuff
+	ps-types	;type/undetermined expand-type-spec
+	linking		;prescheme-compiler-env
+	syntactic	;expand
+	strong
+	external-values
+	locations
+	features)	;immutable?
+  (access forms)	;avoid name conflict with NODE-FORM in nodes
+  (files flatten substitute))
+
+(define-structures ((to-cps (export x->cps)))
+  (open scheme big-scheme comp-util
+	variable
+	names bindings nodes
+	primop
+	structure-refs
+	cps-util enumerated
+	ps-primops 	;get-prescheme-primop
+	ps-types 	;type/unknown
+	inference	;node-type lambda-node-return-type
+	ps-primitives	;primitive-expander
+	protocol)	;goto-protocol normal-protocol
+  (access node)
+  (files to-cps))
+	
+; Processing interface and package definitions
+
+(define-structures ((linking linking-interface))
+  (open scheme big-scheme structure-refs comp-util
+	interfaces packages environments usual-macros
+	defpackage types ;for making interfaces
+        reflective-tower-maker
+	fluids
+	expand-define-record-type
+	scan-package	 ;collect-packages
+	bindings         ;binding? binding-place
+	nodes		 ;get-operator
+	transforms       ;make-transform
+	locations)       ;contents
+  (access meta-types           		;syntax-type usual-variable-type
+	  variable             		;make-global-variable
+	  ps-types             		;type/unknown
+	  reading-forms			;$note-file-package
+	  packages-internal    		;$get-location
+	  package-commands-internal	;config-package
+	  prescheme            		;we need this loaded
+	  built-in-structures) 		;defpackage structure-refs
+  (files linking))
+
+;----------------------------------------------------------------
+; Types and type inference
+
+(define-structures ((ps-types ps-type-interface)
+		    (type-variables type-variable-interface)
+		    (record-types record-type-interface)
+		    (expand-define-record-type
+		     (export expand-define-record-type)))
+  (open scheme big-scheme comp-util defrecord)
+  (files type
+	 type-scheme
+	 type-var
+	 record))
+
+(define-structures ((inference inference-interface)
+		    (inference-internal inference-internal-interface))
+  (open scheme big-scheme front variable comp-util transitive
+	ps-types type-variables
+	bindings nodes
+	structure-refs
+	ps-primitives
+	ps-primops    ; get-prescheme-primop
+	external-values external-constants
+	locations)    ; for imported constants
+  (access eval-node)  ; unspecific?
+  (for-syntax (open scheme big-scheme))
+  (files inference infer-early))
+
+(define-structures ((node-types (export instantiate-type&value
+					make-monomorphic!)))
+  (open scheme big-scheme front node comp-util
+	ps-types type-variables
+	inference-internal)  ; unify!
+  (files node-type))
+
+;----------------------------------------------------------------
+; Primops
+
+(define-structures ((ps-primops ps-primop-interface))
+  (open scheme big-scheme comp-util node simplify-internal
+	linking ps-types front expand)
+  (files (primop primop)))
+
+(define-structures ((ps-c-primops ps-c-primop-interface))
+  (open scheme big-scheme comp-util node simplify-internal
+	define-record-types
+	ps-types ps-primops)
+  (for-syntax (open scheme big-scheme))
+  (files (primop c-primop)))
+
+(define-structures ((primop-data (export)))
+  (open scheme big-scheme comp-util node simplify-internal simplify-let
+	front expand type-variables inference-internal
+	ps-types ps-primops record-types
+	parameters node-vector
+	node-types)   ; instantiate-type&value
+  (files (primop base)
+	 (primop arith)
+	 (primop io)
+	 (primop vector)
+	 ))
+
+(define-structures ((c-primop-data (export)))
+  (open scheme big-scheme comp-util node simplify
+	ps-types ps-primops ps-c-primops
+	front
+	structure-refs
+	c-internal
+	ps-types type-variables inference-internal
+	inference          ; get-variable-type
+	forms byte-vectors
+	record-types
+	eval-node)         ; unspecific?
+  (access ps-primitives prescheme)
+  (files (primop c-base)
+	 (primop c-arith)
+	 (primop c-io)
+	 (primop c-vector)
+	 ))
+
+(define-structures ((external-values (export external-value?
+					     make-external-value
+					     external-value-type
+					     external-value-string)))
+  (open scheme define-record-types)
+  (begin
+    (define-record-type external-value :external-value
+      (make-external-value string type)
+      external-value?
+      (string external-value-string)
+      (type external-value-type))))
+
+;----------------------------------------------------------------
+; Translating to C
+
+(define-structures ((c (export write-c-file hoist-nested-procedures))
+		    (c-internal c-internal-interface))
+  (open scheme big-scheme comp-util strongly-connected node forms
+	defrecord
+	ps-primops ps-c-primops
+	ps-types type-variables
+	flatten-internal   ; generated-top-variable?
+	inference          ; get-variable-type
+	inference-internal ; literal-value-type
+	protocol           ; goto-protocol?
+	i/o		   ; force-output
+	record-types
+	external-values
+	external-constants
+	eval-node)         ; unspecific?
+  (begin (define number-of-char-codes 256))  ; should be somewhere else
+  (files c
+	 c-decl
+	 c-call
+	 hoist
+	 merge))
+
+
diff --git a/ps-compiler/prescheme/primitive.scm b/ps-compiler/prescheme/primitive.scm
new file mode 100644
index 0000000..418a5bd
--- /dev/null
+++ b/ps-compiler/prescheme/primitive.scm
@@ -0,0 +1,46 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+; Eval'ing and type-checking code for primitives.
+
+(define-record-type primitive
+  (id                ; for debugging & making tables
+   arg-predicates    ; predicates for checking argument types
+   eval              ; evaluation function
+   source            ; close-compiled source (if any)
+   expander          ; convert call to one using primops
+   expands-in-place? ; does the expander expand the definition in-line?
+   inference-rule    ; type inference rule
+   )
+  ())
+
+(define make-primitive primitive-maker)
+
+(define-record-discloser type/primitive
+  (lambda (primitive)
+    (list 'primitive (primitive-id primitive))))
+
+(define (eval-primitive primitive args)
+  (cond ((not (primitive? primitive))
+	 (user-error "error while evaluating: ~A is not a procedure" primitive))
+	((args-okay? args (primitive-arg-predicates primitive))
+	 (apply (primitive-eval primitive) args))
+	(else
+	 (user-error "error while evaluating: type error ~A"
+		     (cons (primitive-id primitive) args)))))
+
+; PREDICATES is a (possibly improper) list of predicates that should match
+; ARGS.
+
+(define (args-okay? args predicates)
+  (cond ((atom? predicates)
+	 (if predicates
+	     (every? predicates args)
+	     #t))
+	((null? args)
+	 #f)
+	((car predicates)
+	 (and ((car predicates) (car args))
+	      (args-okay? (cdr args) (cdr predicates))))
+	(else
+	 (args-okay? (cdr args) (cdr predicates)))))
+
diff --git a/ps-compiler/prescheme/primop/arith.scm b/ps-compiler/prescheme/primop/arith.scm
new file mode 100644
index 0000000..0c289d7
--- /dev/null
+++ b/ps-compiler/prescheme/primop/arith.scm
@@ -0,0 +1,250 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define (put-literal-first call)
+  (if (and (not (literal-node? (call-arg call 0)))
+	   (literal-node? (call-arg call 1)))
+      (let ((arg1 (detach (call-arg call 0)))
+	    (arg0 (detach (call-arg call 1))))
+	(attach call 0 arg0)
+	(attach call 1 arg1))))
+
+(define (simplify-add call)
+  (simplify-args call 0)
+  (put-literal-first call)
+  ((pattern-simplifier
+    ((+ '0 x) x)
+    ((+ 'a 'b) '(+ a b))
+    ((+ 'a (+ 'b x)) (+ x '(+ a b)))
+    ((+ 'a (- x 'b)) (+ x '(- a b)))  ; no overflow in Scheme, but what
+    ((+ 'a (- 'b x)) (- '(+ a b) x))  ; about PreScheme?  Could check the
+    ((+ (+ 'a x) (+ 'b y)) (+ '(+ a b) (+ x y)))
+    ((+ x (+ 'a y)) (+ 'a (+ x y))))
+   call))                             ; result of the literal.  Maybe these
+                                      ; should be left out. 
+
+(define-scheme-primop + #f type/integer simplify-add)
+
+(define (simplify-subtract call)
+  (simplify-args call 0)
+  ((pattern-simplifier
+    ((- 'a 'b) '(- a b))
+    ((- x 'a) (+ '(- 0 a) x))
+    ((- 'a (+ 'b x)) (- '(- a b) x))   ; more overflow problems
+    ((- 'a (- 'b x)) (+ x '(- a b)))
+    ((- x (+ 'a y)) (+ '(- 0 a) (- x y)))
+;    ((- (+ 'a x) y) (+ 'a (- x y)))  hmm - need to come up with a normal form
+    ((- (+ 'a x) (+ 'b y)) (- (+ '(- a b) x) y)))
+   call))
+
+(define-scheme-primop - #f type/integer simplify-subtract)
+
+; This should check for multiply by powers of 2 (other constants can be
+; done later).
+
+(define (simplify-multiply call)
+  (simplify-args call 0)
+  (put-literal-first call)
+  (cond ((power-of-two-literal (call-arg call 0))
+	 => (lambda (i)
+	      (set-call-primop! call (get-prescheme-primop 'ashl))
+	      (replace (call-arg call 0) (detach (call-arg call 1)))
+	      (attach call 1 (make-literal-node i type/unknown))))
+	(else
+	 ((pattern-simplifier
+	   ((* '0 x) '0)
+	   ((* '1 x) x)
+	   ((* 'a 'b) '(* a b))
+	   ((* 'a (* x 'b)) (* x '(* a b)))
+	   ((* 'a (* 'b x)) (* x '(* a b))))
+	  call))))
+
+(define-scheme-primop *      #f type/integer simplify-multiply)
+(define-scheme-primop small* #f type/integer simplify-multiply)
+
+(define (simplify-quotient call)
+  (simplify-args call 0)
+  (cond ;((power-of-two-literal (call-arg call 1))
+	; => (lambda (i)
+	;      (set-call-primop! call (get-prescheme-primop 'ashr))
+	;      (replace (call-arg call 1) (make-literal-node i type/unknown))))
+	(else
+	 ((pattern-simplifier
+	   ((quotient x '0) '((lambda ()
+				(error "program divides by zero"))))
+	   ((quotient x '1) x)
+	   ((quotient '0 x) '0)
+	   ((quotient 'a 'b) '(quotient a b)))
+	  call))))
+
+(define (power-of-two-literal node)
+  (if (not (literal-node? node))
+      #f
+      (let ((value (literal-value node)))
+	(if (not (and (integer? value)
+		      (<= 1 value)))
+	    #f
+	    (do ((v value (arithmetic-shift v -1))
+		 (i 0 (+ i 1)))
+		((odd? v)
+		 (if (= v 1) i #f)))))))
+
+(define-scheme-primop quotient  exception type/integer simplify-quotient)
+(define-scheme-primop remainder exception type/integer)
+
+(define (simplify-ashl call)
+  (simplify-args call 0)
+  ((pattern-simplifier
+    ((ashl '0 x) '0)
+    ((ashl x '0) x)
+    ((ashl 'a 'b) '(arithmetic-shift a b))
+    ((ashl (ashl x 'a) 'b) (ashl x '(+ a b)))
+    ((ashl (ashr x 'a) 'b)
+     (<= a b)    ; condition
+     (ashl (bitwise-and x '(bitwise-not (- (expt 2 a) 1))) '(- b a)))
+    ((ashl (ashr x 'a) 'b)
+     (>= a b)    ; condition
+     (bitwise-and (ashr x '(- a b)) '(bitwise-not (- (expt 2 b) 1))))
+    ((ashl (+ 'a x) 'b) (+ (ashl x 'b) '(arithmetic-shift a b))))
+   call))
+
+(define (simplify-ashr call)
+  (simplify-args call 0)
+  ((pattern-simplifier
+    ((ashr '0 x) '0)
+    ((ashr x '0) x)
+    ((ashr 'a 'b) '(arithmetic-shift a (- b)))
+    ((ashr (ashr x 'a) 'b) (ashr x '(+ a b))))
+   call))
+
+(define (simplify-lshr call)
+  (simplify-args call 0)
+  ((pattern-simplifier
+    ((lshr '0 x) '0)
+    ((lshr x '0) x)
+    ((lshr 'a 'b) '(lshr a (- b)))
+    ((lshr (lshr x 'a) 'b) (lshr x '(+ a b)))
+    ((ashr (lshr x 'a) 'b) (lshr x '(+ a b)))) ; depends on shifts by zero
+                                               ; having been constant folded
+   call))
+
+(define-scheme-primop ashl #f type/integer simplify-ashl)
+(define-scheme-primop ashr #f type/integer simplify-ashr)
+(define-scheme-primop lshr #f type/integer simplify-lshr)
+
+(define (simplify-bitwise-and call)
+  (simplify-args call 0)
+  (put-literal-first call)
+  ((pattern-simplifier
+    ((bitwise-and '0 x) '0)
+    ((bitwise-and '-1 x) x)
+    ((bitwise-and 'a 'b) '(bitwise-and a b)))
+   call))
+
+(define (simplify-bitwise-ior call)
+  (simplify-args call 0)
+  (put-literal-first call)
+  ((pattern-simplifier
+    ((bitwise-ior '0 x) x)
+    ((bitwise-ior '-1 x) '-1)
+    ((bitwise-ior 'a 'b) '(bitwise-ior a b)))
+   call))
+
+(define (simplify-bitwise-xor call)
+  (simplify-args call 0)
+  (put-literal-first call)
+  ((pattern-simplifier
+    ((bitwise-xor '0 x) x)
+    ((bitwise-xor 'a 'b) '(bitwise-xor a b)))
+   call))
+
+(define (simplify-bitwise-not call)
+  (simplify-args call 0)
+  ((pattern-simplifier
+    ((bitwise-not 'a) '(bitwise-not a)))
+   call))
+
+(define-scheme-primop bitwise-and #f type/integer simplify-bitwise-and)
+(define-scheme-primop bitwise-ior #f type/integer simplify-bitwise-ior)
+(define-scheme-primop bitwise-xor #f type/integer simplify-bitwise-xor)
+(define-scheme-primop bitwise-not #f type/integer simplify-bitwise-not)
+
+(define (simplify-= call)
+  (simplify-args call 0)
+  (put-literal-first call)
+  ((pattern-simplifier
+    ((= 'a 'b) '(= a b))
+    ((= 'a (+ 'b c)) (= '(- a b) c))   ; will these ever be used?
+    ((= 'a (- 'b c)) (= '(- b a) c)))
+   call))
+
+(define (simplify-< call)
+  (simplify-args call 0)
+  ((pattern-simplifier
+    ((< 'a 'b) '(< a b))
+    ((< 'a (+ 'b c)) (< '(- a b) c))   ; will these ever be used?
+    ((< (+ 'b c) 'a) (< c '(- a b)))
+    ((< 'a (- 'b c)) (< c '(- b a)))
+    ((< (- 'b c) 'a) (< '(- b a) c)))
+   call))
+
+(define (simplify-char=? call)
+  (simplify-args call 0)
+  (put-literal-first call)
+  ((pattern-simplifier
+    ((char=? 'a 'b) '(char=? a b))
+    ((char=? 'a (+ 'b c)) (char=? '(- a b) c))
+    ((char=? 'a (- 'b c)) (char=? '(- b a) c)))
+   call))
+
+(define (simplify-char<? call)
+  (simplify-args call 0)
+  ((pattern-simplifier
+    ((char<? 'a 'b) '(char<? a b))
+    ((char<? 'a (+ 'b c)) (char<? '(- a b) c))
+    ((char<? (+ 'b c) 'a) (char<? c '(- a b)))
+    ((char<? 'a (- 'b c)) (char<? c '(- b a)))
+    ((char<? (- 'b c) 'a) (char<? '(- b a) c)))
+   call))
+
+(define bool-type
+  (lambda (call)
+    type/boolean))
+
+(define-scheme-primop =      #f bool-type simplify-=)
+(define-scheme-primop <      #f bool-type simplify-<)
+(define-scheme-primop char=? #f bool-type simplify-char=?)
+(define-scheme-primop char<? #f bool-type simplify-char<?)
+
+(define (simplify-char->ascii call)
+  (simplify-args call 0)
+  (let ((arg (call-arg call 0)))
+    (if (literal-node? arg)
+	(let ((value (literal-value arg)))
+	  (if (char? value)
+	      (replace call (make-literal-node (char->ascii value) #f))
+	      (breakpoint "char->ascii is applied to a non-character literal ~S"
+			  value))))))
+			  
+(define (simplify-ascii->char call)
+  (simplify-args call 0)
+  (let ((arg (call-arg call 0)))
+    (if (literal-node? arg)
+	(let ((value (literal-value arg)))
+	  (if (integer? value)
+	      (replace call (make-literal-node (ascii->char value) #f))
+	      (breakpoint "ascii->char is applied to a non-integer literal ~S"
+			  value))))))
+
+(define-scheme-primop char->ascii #f type/integer simplify-char->ascii)
+(define-scheme-primop ascii->char #f type/integer simplify-ascii->char)
+
+;(define (simplify-sign-extend call)
+;  (simplify-args call 0)
+;  (let ((value (call-arg call 0)))
+;    (cond ((literal-node? value)
+;           (set-literal-type! value type/integer)
+;           (replace call (detach value))))))
+;
+;(define-scheme-primop sign-extend #f type/integer simplify-sign-extend)
+;(define-scheme-primop zero-extend #f type/integer simplify-sign-extend)
diff --git a/ps-compiler/prescheme/primop/base.scm b/ps-compiler/prescheme/primop/base.scm
new file mode 100644
index 0000000..5843d0f
--- /dev/null
+++ b/ps-compiler/prescheme/primop/base.scm
@@ -0,0 +1,159 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+(define (simplify-letrec1 call)
+  (let* ((cont (call-arg call 0))
+	 (next (lambda-body cont))
+	 (var (car (lambda-variables cont))))
+    (if (not (and (calls-this-primop? next 'letrec2)
+		  (= 1 (length (variable-refs var)))
+		  (eq? next (node-parent (car (variable-refs var))))
+		  (= 1 (node-index (car (variable-refs var))))))
+	(error "badly formed LETREC ~S ~S" call (node-parent call)))
+    (simplify-args call 0)
+    (check-letrec-scoping call cont next)
+    (if (every? unused? (cdr (lambda-variables cont)))
+	(replace-body call (detach-body (lambda-body (call-arg next 0)))))))
+
+(define (check-letrec-scoping letrec1 binder letrec2)
+  (let ((values (sub-vector->list (call-args letrec2) 2))
+	(body (call-arg letrec2 0)))
+    (for-each (lambda (n) (set-node-flag! n 'okay)) values)
+    (set-node-flag! body 'okay)
+    (for-each (lambda (var)
+		(for-each (lambda (ref)
+			    (set-node-flag! (marked-ancestor ref) 'lose))
+			  (variable-refs var)))
+	      (cdr (lambda-variables binder)))
+    (let ((non-recur (filter (lambda (p)
+			       (eq? (node-flag (car p)) 'okay))
+			     (map cons values (cdr (lambda-variables binder))))))
+      (for-each (lambda (n) (set-node-flag! n #f)) values)
+      (set-node-flag! body #f)
+      (if (not (null? non-recur))
+	  (letrec->let (map car non-recur)
+		       (map cdr non-recur)
+		       letrec1 binder letrec2)))))
+
+(define (letrec->let vals vars letrec1 binder letrec2)
+  (for-each detach vals)
+  (remove-null-arguments letrec2
+			 (- (vector-length (call-args letrec2))
+			    (length vals)))
+  (set-lambda-variables!
+   binder
+   (filter (lambda (v) (not (memq v vars)))
+	   (lambda-variables binder)))
+  (move-body letrec1
+	     (lambda (letrec1)
+	       (let-nodes ((call (let 1 l1 . vals))
+			   (l1 vars letrec1))
+		 call))))
+
+; (return (lambda (a) ...) x)
+;  =>
+; (let (lambda (a) ...) x)
+
+(define (simplify-ps-return call)
+  (let ((cont (call-arg call 0))
+	(value (call-arg call 1)))
+    (cond ((not (lambda-node? cont))
+	   (default-simplifier call))
+	  (else
+	   (set-call-primop! call (get-primop (enum primop let)))
+	   (set-call-exits! call 1)
+	   (set-node-simplified?! call #f)))))
+
+(make-primop 'dispatch         #f #f default-simplifier (lambda (call) 1) #f)
+(make-primop 'let              #f #f simplify-let       (lambda (call) 1) #f)
+(make-primop 'letrec1          #f #f (lambda (call)
+				       (simplify-letrec1 call))  (lambda (call) 1) #f)
+(make-primop 'letrec2          #f #f default-simplifier (lambda (call) 1) #f)
+(make-primop 'undefined-value  #t #f default-simplifier
+	     (lambda (call) 1)
+	     (lambda (call) type/null))
+(make-primop 'undefined-effect #t #f default-simplifier
+	     (lambda (call) 1)
+	     (lambda (call) type/null))
+(make-primop 'global-ref       #t 'read default-simplifier
+	     (lambda (call) 1)
+	     (lambda (call)
+	       (variable-type (reference-variable (call-arg call 0)))))
+
+;(make-primop 'allocate         #f #f 'allocate simplify-allocation (lambda (call) 1))
+
+(make-primop 'global-set!      #f 'write default-simplifier
+	     (lambda (call) 1) #f)
+
+(make-proc-primop 'call 'write simplify-known-call
+		  (lambda (call) 1) 1)
+(make-proc-primop 'tail-call 'write simplify-known-tail-call
+		  (lambda (call) 1) 1)
+(make-proc-primop 'return #f   simplify-ps-return  (lambda (call) 1) 0)
+(make-proc-primop 'jump   #f   simplify-jump       (lambda (call) 1) 0)
+(make-proc-primop 'throw  #f   default-simplifier  (lambda (call) 1) 0)
+
+; This delays simplifying the arguments until we see if the procedure
+; is a lambda-node.
+
+(define (simplify-unknown-call call)
+  (simplify-arg call 1)   ; simplify the procedure
+  (let ((proc (call-arg call 1)))
+    (cond ((lambda-node? proc)
+	   (determine-lambda-protocol proc (list proc))
+	   (mark-changed proc))
+	  ((and (reference-node? proc)
+		(variable-simplifier (reference-variable proc)))
+           => (lambda (proc)
+		(proc call)))
+	  (else
+	   (simplify-args call 0)))))  ; simplify all arguments
+
+(make-proc-primop 'unknown-call 'write simplify-unknown-call
+		  (lambda (call) 1) 1)
+(make-proc-primop 'unknown-tail-call 'write simplify-unknown-call
+		  (lambda (call) 1) 1)
+(make-proc-primop 'unknown-return #f default-simplifier
+		  (lambda (call) 1) 0)
+
+(define (simplify-unspecific call)
+  (let ((node (make-undefined-literal)))
+    (set-literal-type! node type/null)
+    (replace call node)))
+
+(define-scheme-primop unspecific #f type/null simplify-unspecific)
+
+(define-scheme-primop uninitialized-value type/null)
+(define-scheme-primop null-pointer?       type/boolean)
+(define-scheme-primop null-pointer        type/boolean) ; type can't be right
+
+(define-scheme-primop eq? type/boolean)  ; should have a simplifier
+
+;(define (exp->type exp)
+;  (if (quote-exp? exp)
+;      (real-exp->type (quote-exp-value exp))
+;      (error "can't turn ~S into a type" exp)))
+;
+;(define (real-exp->type exp)
+;  (let ((lose (lambda () (error "can't turn ~S into a type" exp))))
+;    (let label ((exp exp))
+;      (cond ((pair? exp)
+;             (case (car exp)
+;               ((pointer)
+;                (make-pointer-type (label (cadr exp))))
+;               ((arrow)
+;                (make-arrow-type (map label (cadr exp)) (caddr exp)))
+;               (else
+;                (lose))))
+;            ((and (symbol? exp)
+;                  (lookup-type exp))
+;             => identity)
+;            (else
+;             (lose))))))
+
+(define-scheme-cond-primop test simplify-test expand-test simplify-test?)
+
+;(define-primitive-expander 'unspecific 0
+;  (lambda (source args cenv)
+;    (make-quote-exp the-undefined-value type/unknown)))
+
+
diff --git a/ps-compiler/prescheme/primop/c-arith.scm b/ps-compiler/prescheme/primop/c-arith.scm
new file mode 100644
index 0000000..5073f01
--- /dev/null
+++ b/ps-compiler/prescheme/primop/c-arith.scm
@@ -0,0 +1,93 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+(define-local-syntax (define-c-arith-binop-generator id c-op)
+  `(define-c-generator ,id #t
+     (lambda (call port indent)
+       (simple-c-primop ,c-op call port))))
+
+(define-c-arith-binop-generator + "+")
+(define-c-arith-binop-generator - "-")
+(define-c-arith-binop-generator * "*")
+(define-c-arith-binop-generator quotient  "/")
+
+(define-c-generator small* #t
+  (lambda (call port indent)
+    (format port "PS_SMALL_MULTIPLY(")
+    (c-value (call-arg call 0) port)
+    (format port ", ")
+    (c-value (call-arg call 1) port)
+    (format port ")")))
+
+(define-c-arith-binop-generator remainder "%")
+(define-c-arith-binop-generator bitwise-and "&")
+(define-c-arith-binop-generator bitwise-ior "|")
+(define-c-arith-binop-generator bitwise-xor "^")
+
+(define-c-generator ashl #t
+  (lambda (call port indent)
+    (generate-shift call port indent "LEFT" "<<" #f)))
+
+(define-c-generator ashr #t
+  (lambda (call port indent)
+    (generate-shift call port indent "RIGHT" ">>" #f)))
+
+(define-c-generator lshr #t
+  (lambda (call port indent)
+    (generate-shift call port indent "RIGHT_LOGICAL" ">>" #t)))
+
+(define (generate-shift call port indent macro c-op logical?)
+  (cond ((= 1 (call-exits call))
+	 ; PS_SHIFT_??? is a C macro that handles overshifting even if C doesn't
+	 (indent-to port indent)
+	 (format port "PS_SHIFT_~A(" macro)
+	 (if logical? (format port "(unsigned long)"))
+	 (c-value (call-arg call 1) port)
+	 (format port ", ")
+	 (c-value (call-arg call 2) port)
+	 (format port ", ")
+	 (c-variable (car (lambda-variables (call-arg call 0))) port)
+	 (format port ")"))
+	((>= (literal-value (call-arg call 1)) prescheme-integer-size)
+	 (format port "0L"))
+	(else
+	 (if logical?
+	     (format port "(long)(((unsigned long)")
+	     (format port "(("))
+	 (c-value (call-arg call 0) port)
+	 (format port ")~A" c-op)
+	 (c-value (call-arg call 1) port)
+	 (format port ")"))))
+    
+(define-c-generator bitwise-not #t
+  (lambda (call port indent)
+    (simple-c-primop "~" call port)))
+
+(define-local-syntax (define-c-comp-binop-generator id c-op)
+  `(define-c-generator ,id #t
+     (lambda (call port indent)
+       (simple-c-primop ,c-op call port))))
+
+(define-c-comp-binop-generator =      "==")
+(define-c-comp-binop-generator <      "<" )
+(define-c-comp-binop-generator char=? "==")
+(define-c-comp-binop-generator char<? "<" )
+
+(define-c-generator ascii->char #t
+  (lambda (call port indent)
+    (c-value (call-arg call 0) port)))
+    
+(define-c-generator char->ascii #t
+  (lambda (call port indent)
+    (c-value (call-arg call 0) port)))
+    
+;(define-c-generator sign-extend #t
+;  (lambda (call port indent)
+;    (display "((long) " port)
+;    (c-value (call-arg call 0) port)
+;    (display ")" port)))
+;
+;(define-c-generator zero-extend #t
+;  (lambda (call port indent)
+;    (display "((unsigned long) " port)
+;    (c-value (call-arg call 0) port)
+;    (display ")" port)))
diff --git a/ps-compiler/prescheme/primop/c-base.scm b/ps-compiler/prescheme/primop/c-base.scm
new file mode 100644
index 0000000..ff6b885
--- /dev/null
+++ b/ps-compiler/prescheme/primop/c-base.scm
@@ -0,0 +1,343 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+(define-c-generator let #f
+  (lambda (call port indent)
+    (let ((args (call-args call))
+	  (vars (lambda-variables (call-arg call 0))))
+      (do ((i 1 (+ i 1))
+	   (vars vars (cdr vars)))
+	  ((null? vars))
+	(let ((val (vector-ref args i)))
+	  (if (not (lambda-node? val))
+	      (c-assignment (car vars) val port indent)))))))
+
+(define-c-generator letrec1 #f
+  (lambda (call port indent)
+    (values)))
+
+(define-c-generator letrec2 #f
+  (lambda (call port indent)
+    (values)))
+
+(define-c-generator jump #f
+  (lambda (call port indent)
+    (let ((proc (called-lambda call)))
+      (assign-argument-vars (lambda-variables proc) call 1 port indent)
+      (indent-to port indent)
+      (display "goto " port)
+      (writec port #\L)
+      (display (lambda-id proc) port)
+      (write-char #\; port)
+      (note-jump-generated! proc)
+      (values))))
+  
+(define (assign-argument-vars vars call start port indent)
+  (really-assign-argument-vars vars call start "arg" port indent))
+
+(define (assign-merged-argument-vars vars call start port indent)
+  (really-assign-argument-vars vars call start "merged_arg" port indent))
+
+(define (assign-global-argument-vars vars call start port indent)
+  (really-assign-argument-vars vars call start "goto_arg" port indent))
+
+(define (really-assign-argument-vars vars call start name port indent)
+  (let ((args (call-args call)))
+    (do ((i start (+ i 1))
+	 (vars vars (cdr vars)))
+	((>= i (vector-length args)))
+      (if (not (or (undefined-value-node? (vector-ref args i))
+		   (eq? type/unit (get-variable-type (car vars)))))
+	  (c-assignment (c-argument-var name
+					(get-variable-type (car vars))
+					(- i start)
+					port)
+			(vector-ref args i)
+			port indent)))))
+
+; Calls
+
+; Unknown calls have a first argument of 'goto if they are supposed to be
+; tail-recursive.  For known calls the protocol field of the lambda node
+; is set to 'tail-called if any of the calls are supposed to be tail-recursive.
+;
+; Calls to non-tail-called procedures are just regular C calls.  For tail-
+; called procedures there are two kinds of calls:
+;  Tail-call from a tail-called procedure: proceed through the driver loop
+;  All others: start a driver loop
+;
+; Known and unknown calls are handled identically, except that known calls
+; may be to merged procedures.
+;
+; Merged procedures with GOTO calls:
+;  This works if we merge the return points as well.  Possibly there should be
+; one return switch per C procedure.  There do have to be separate return point
+; variables (and one global one for the switch).
+
+(define-c-generator call #f
+  (lambda (call port indent)
+    (cond ((merged-procedure-reference (call-arg call 1))
+	   => (lambda (form)
+		(generate-merged-call call 2 form port indent)))
+	  (else
+           (generate-c-call call 2 port indent)))))
+
+(define-c-generator tail-call #f
+  (lambda (call port indent)
+    (cond ((merged-procedure-reference (call-arg call 1))
+	   => (lambda (form)
+		(generate-merged-goto-call call 2 form port indent)))
+	  (else
+           (generate-c-tail-call call 2 port indent)))))
+
+(define-c-generator unknown-call #f
+  (lambda (call port indent)
+    (if (goto-protocol? (literal-value (call-arg call 2)))
+	(user-warning "ignoring GOTO declaration for non-tail-recursive call to"
+		      (variable-name (reference-variable
+				      (call-arg call 1)))))
+    (generate-c-call call 3 port indent)))
+
+(define-c-generator unknown-tail-call #f
+  (lambda (call port indent)
+    (generate-c-tail-call call 3 port indent)))
+
+(define (generate-merged-goto-call call start form port indent)
+  (let ((proc (form-value form)))
+    (assign-merged-argument-vars (cdr (lambda-variables proc))
+				 call start
+				 port indent)
+    (indent-to port indent)
+    (display "goto " port)
+    (display (form-c-name form) port)
+    (write-char #\; port)
+    (values)))
+
+(define (generate-goto-call call start port indent)
+  (let ((proc (call-arg call 1)))
+    (if (not (global-reference? proc))
+	(bug "incorrect procedure in goto call ~S" call))
+    (assign-global-argument-vars (cdr (lambda-variables
+				       (global-lambda
+					(reference-variable proc))))
+				 call start
+				 port indent)
+    ; T is the marker for the tail-call version of the procedure
+    (indent-to port indent)
+    (display "return((long)T" port)
+    (c-value proc port)
+    (display ");" port)))
+
+(define (global-lambda var)
+  (let ((form (maybe-variable->form var)))
+    (if (and form
+	     (or (eq? 'lambda (form-type form))
+		 (eq? 'merged (form-type form))))
+	(form-value form)
+	(bug "value of ~S, called using goto, is not a known procedure"
+	       var))))
+
+; C requires that we dereference all but calls to global functions.
+; Calls to literals are macros that must take care of themselves.
+
+(define (generate-c-call call start port indent)
+  (let ((vars (lambda-variables (call-arg call 0)))
+        (args (call-args call))
+        (proc (call-arg call 1)))
+    (if (and (global-reference? proc)
+	     (memq? 'tail-called (variable-flags (reference-variable proc))))
+	(call-with-driver-loop call start port indent (car vars))
+	(let ((deref? (or (and (reference-node? proc)
+			       (variable-binder (reference-variable proc)))
+			  (call-node? proc))))
+	   (c-assign-to-variable (car vars) port indent)
+	   (if deref?
+	       (display "(*" port))
+	   (c-value proc port)
+	   (if deref?
+	       (writec port #\)))
+	   (write-value+result-var-list args start (cdr vars) port)))
+    (writec port #\;)
+    (values)))
+
+(define (generate-c-tail-call call start port indent)
+  (let ((proc (call-arg call 1))
+	(args (call-args call)))
+    (cond ((not (and (global-reference? proc)
+		     (memq? 'tail-called
+			    (variable-flags (reference-variable proc)))))
+	   (indent-to port indent)
+	   (display "return " port)
+	   (c-value proc port)
+	   (write-value-list-with-extras args start *extra-tail-call-args* port))
+	  (*doing-tail-called-procedure?*
+	   (generate-goto-call call start port indent))
+	  (else
+	   (call-with-driver-loop call start port indent #f)))
+    (writec port #\;)
+    (values)))
+
+(define (global-reference? node)
+  (and (reference-node? node)
+       (global-variable? (reference-variable node))))
+
+(define (call-with-driver-loop call start port indent result-var)	   
+  (let* ((proc-var (reference-variable (call-arg call 1)))
+	 (vars (lambda-variables (global-lambda proc-var))))
+    (assign-global-argument-vars (cdr vars) call start port indent)
+    (if result-var
+	(c-assign-to-variable result-var port indent)
+	(begin
+	  (indent-to port indent)
+	  (display "return " port)))
+    (display "TTrun_machine((long)" port)
+    (display "T" port)
+    (write-c-identifier (variable-name proc-var) port)
+    (display ")" port)))
+
+(define (generate-merged-call call start form port indent)
+  (let ((return-index (form-return-count form))
+	(name (form-c-name form))
+	(res (lambda-variables (call-arg call 0))))
+    (set-form-return-count! form (+ 1 return-index))
+    (assign-merged-argument-vars (cdr (lambda-variables (form-value form)))
+				 call start port indent)
+    (indent-to port indent)
+    (format port "~A_return_tag = ~D;" name return-index)
+    (indent-to port indent)
+    (format port "goto ~A;" name)
+    (indent-to port (- indent 1))
+    (format port "~A_return_~S:" name return-index)
+    (do ((i 0 (+ i 1))
+	 (res res (cdr res)))
+	((null? res))
+      (let ((var (car res)))
+	(cond ((and (used? var)
+		    (let ((type (get-variable-type var)))
+		      (and (not (eq? type type/unit))
+			   (not (eq? type type/null)))))
+	       (c-assign-to-variable var port indent)
+	       (format port "~A~D_return_value;" name i)))))))
+
+; Returns
+
+(define-c-generator return #f
+  (lambda (call port indent)
+    (if *current-merged-procedure*
+	(generate-return-from-merged-call call 1 port indent)
+	(really-generate-c-return call 1 port indent))))
+
+(define-c-generator unknown-return #f
+  (lambda (call port indent)
+    (cond (*doing-tail-called-procedure?*
+	   (generate-return-from-tail-call call port indent))
+	  (*current-merged-procedure*
+	   (generate-return-from-merged-call call 1 port indent))
+	  (else
+	   (really-generate-c-return call 1 port indent)))))
+
+(define (generate-return-from-tail-call call port indent)
+  (if (not (no-value-node? (call-arg call 1)))
+      (c-assignment "TTreturn_value" (call-arg call 1) port indent))
+  (indent-to port indent)
+  (display "return(0L);" port))
+
+(define (generate-return-from-merged-call call start port indent)
+  (let ((name *current-merged-procedure*))
+    (do ((i start (+ i 1)))
+	((= i (call-arg-count call)))
+      (let ((arg (call-arg call i)))
+	(if (not (no-value-node? arg))
+	    (c-assignment (format #f "~A~D_return_value" name (- i start))
+			  arg port indent))))
+    (indent-to port indent)
+    (format port "goto ~A_return;" name)))
+
+(define (really-generate-c-return call start port indent)
+  (do ((i (+ start 1) (+ i 1)))
+      ((= i (call-arg-count call)))
+    (let ((arg (call-arg call i)))
+      (if (not (no-value-node? arg))
+	  (begin
+	    (indent-to port indent)
+	    (format port "*TT~D = " (- (- i start) 1))
+	    (c-value arg port)
+	    (write-char #\; port)))))
+  (indent-to port indent)
+  (display "return" port)
+  (if (not (no-value-node? (call-arg call start)))
+      (begin
+	(write-char #\space port)
+	(c-value (call-arg call start) port)))
+  (display ";" port)
+  (values))
+
+; Allocate
+
+;(define-c-generator allocate #f
+;  (lambda (call port indent)
+;    (let ((cont (call-arg call 0))
+;          (size (call-arg call 1)))
+;      (c-assign-to-variable (car (lambda-variables cont)) port indent)
+;      (display "(long) malloc(" port)
+;      (c-value size port)
+;      (display "* sizeof(char));" port))))
+
+(define-c-generator global-ref #t
+  (lambda (call port indent)
+    (c-value (call-arg call 0) port)))
+  
+(define-c-generator global-set! #f
+  (lambda (call port indent)
+    (let ((value (call-arg call 2)))
+      (if (not (and (literal-node? value)
+		    (unspecific? (literal-value value))))
+	  (c-assignment (reference-variable (call-arg call 1))
+			value
+			port indent)))))
+
+; if (ARG1 OP ARG2) {
+;   cont1 }
+; else {
+;   cont2 }
+
+(define-c-generator test #f
+  (lambda (call port indent)
+    (destructure ((#(cont1 cont2 value) (call-args call)))
+      (generate-c-conditional-prelude port indent)
+      (c-value value port)
+      (generate-c-conditional-jumps cont1 cont2 port indent))))
+
+(define (generate-c-conditional-prelude port indent)
+  (indent-to port indent)
+  (display "if " port)
+  (writec port #\())
+
+(define (generate-c-conditional-jumps cont1 cont2 port indent)
+  (display ") {" port)
+  (write-c-block (lambda-body cont1) port (+ indent 2))
+  (newline port)
+  (indent-to port indent)
+  (display "else {" port)
+  (write-c-block (lambda-body cont2) port (+ indent 2)))
+
+(define-c-generator unspecific #t
+  (lambda (call port indent)
+    (bug "generating code for undefined value ~S" call)))
+
+(define-c-generator uninitialized-value #t
+  (lambda (call port indent)
+    (bug "generating code for uninitialized value ~S" call)))
+
+(define-c-generator null-pointer? #t
+  (lambda (call port indent)
+    (display "NULL == " port)
+    (c-value (call-arg call 0) port)))
+
+(define-c-generator null-pointer #t
+  (lambda (call port indent)
+    (display "NULL" port)))
+
+(define-c-generator eq? #t
+  (lambda (call port indent)
+    (simple-c-primop "==" call port)))
+
diff --git a/ps-compiler/prescheme/primop/c-io.scm b/ps-compiler/prescheme/primop/c-io.scm
new file mode 100644
index 0000000..7eff01f
--- /dev/null
+++ b/ps-compiler/prescheme/primop/c-io.scm
@@ -0,0 +1,169 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+(define (write-c-io-call call port name . args)
+  (format port name)
+  (writec port #\()
+  (for-each (lambda (arg)
+	      (cond ((string? arg)
+		     (format port arg))
+		    ((variable? arg)
+		     (c-variable arg port))
+		    (else
+		     (c-value (call-arg call arg) port))))
+	    args)
+  (writec port #\)))
+
+; stdin, stdout, and stderr cannot be variables because they may be macros in C.
+
+(define-c-generator stdin #t
+  (lambda (call port indent)
+    (format port "stdin")))
+
+(define-c-generator stdout #t
+  (lambda (call port indent)
+    (format port "stdout")))
+
+(define-c-generator stderr #t
+  (lambda (call port indent)
+    (format port "stderr")))
+
+; char eof? status
+
+(define-c-generator read-char #f
+  (lambda (call port indent)
+    (indent-to port indent)
+    (let ((vars (lambda-variables (call-arg call 0))))
+      (write-c-io-call call port "PS_READ_CHAR" 1 ", "
+		       (car vars) ", " (cadr vars) ", " (caddr vars)))))
+
+(define-c-generator peek-char #f
+  (lambda (call port indent)
+    (indent-to port indent)
+    (let ((vars (lambda-variables (call-arg call 0))))
+      (write-c-io-call call port "PS_PEEK_CHAR" 1 ", "
+		       (car vars) ", " (cadr vars) ", " (caddr vars)))))
+
+(define-c-generator read-integer #f
+  (lambda (call port indent)
+    (indent-to port indent)
+    (let ((vars (lambda-variables (call-arg call 0))))
+      (write-c-io-call call port "PS_READ_INTEGER" 1 ", "
+		       (car vars) ", " (cadr vars) ", " (caddr vars)))))
+
+(define-c-generator write-char #f
+  (lambda (call port indent)
+    (indent-to port indent)
+    (let ((vars (lambda-variables (call-arg call 0))))
+      (if (used? (car vars))
+	  (write-c-io-call call port "PS_WRITE_CHAR" 1 ", " 2 ", " (car vars))
+	  (begin
+	    (display "{ long ignoreXX;" port)
+	    (indent-to port indent)
+	    (write-c-io-call call port "PS_WRITE_CHAR" 1 ", " 2 ", ignoreXX")
+	    (display " }" port))))))
+
+(define-c-generator write-string #t
+  (lambda (call port indent)
+    (write-c-io-call call port "ps_write_string" 0 ", " 1)))
+
+(define-c-generator write-integer #t
+  (lambda (call port indent)
+    (write-c-io-call call port "ps_write_integer" 0 ", " 1)))
+
+(define-c-generator force-output #t
+  (lambda (call port indent)
+    (write-c-io-call call port "ps_flush" 0)))
+
+(define-c-generator read-block #f
+  (lambda (call port indent)
+    (let ((vars (lambda-variables (call-arg call 0))))
+      (c-assign-to-variable (car vars) port indent)
+      (write-c-io-call call port "ps_read_block" 1 ", ((char *) " 2 "), " 3
+		       ", &" (cadr vars) ", &" (caddr vars))
+      (write-char #\; port))))
+
+(define-c-generator write-block #t
+  (lambda (call port indent)
+    (write-c-io-call call port "ps_write_block" 0 ", ((char *) " 1 ")"
+		     ", " 2)))
+
+; (read-block (lambda (okay? eof? got) ...) port buffer count)
+;
+;(define-c-generator read-block #f
+;  (lambda (call port indent)
+;    (let* ((cont (call-arg call 0))
+;           (vars (lambda-variables cont)))
+;      ;;  got = ps_read(port, buffer, count, &okay?, &eof?);
+;      (c-assign-to-variable (caddr vars) port indent)
+;      (write-c-io-call call port
+;                       "ps_read" 1 ", (void *)" 2 ", " 3 ", &" (car vars)
+;                       ", &" (cadr vars))
+;      (write-char #\; port))))
+;
+;; (write-block (lambda (okay? sent) ...) port buffer count)
+;
+;(define-c-generator write-block #f
+;  (lambda (call port indent)
+;    (let* ((cont (call-arg call 0))
+;           (vars (lambda-variables cont)))
+;      ;;  sent = ps_write(port, buffer, count, &okay?);
+;      (c-assign-to-variable (cadr vars) port indent)
+;      (write-c-io-call call port
+;                       "ps_write" 1 ", (void *)" 2 ", " 3 ", &" (car vars))
+;      (write-char #\; port))))
+
+(define-c-generator open-input-file #f
+  (lambda (call port indent)
+    (let ((vars (lambda-variables (call-arg call 0))))
+      (c-assign-to-variable (car vars) port indent)
+      (write-c-io-call call port "ps_open_input_file" 1 ", &" (cadr vars))
+      (write-char #\; port))))
+
+(define-c-generator open-output-file #f
+  (lambda (call port indent)
+    (let ((vars (lambda-variables (call-arg call 0))))
+      (c-assign-to-variable (car vars) port indent)
+      (write-c-io-call call port "ps_open_output_file" 1 ", &" (cadr vars))
+      (write-char #\; port))))
+
+(define-c-generator close-input-port #t
+  (lambda (call port indent)
+    (write-c-io-call call port "ps_close" 0)))
+
+(define-c-generator close-output-port #t
+  (lambda (call port indent)
+    (write-c-io-call call port "ps_close" 0)))
+
+(define-c-generator abort #t
+  (lambda (call port indent)
+    (format port "(exit -1)")))
+
+(define-c-generator error #f
+  (lambda (call port indent)
+    (indent-to port indent)
+    (format port "ps_error(")
+    (c-value (call-arg call 1) port)
+    (format port ", ~D" (- (call-arg-count call) 2))
+    (do ((i 2 (+ i 1)))
+	((= i (call-arg-count call)))
+      (format port ", ")
+      (c-value (call-arg call i) port))
+    (format port ");")))
+
+(define-c-generator error-string #t
+  (lambda (call port indent)
+    (write-c-io-call call port "ps_error_string" 0)))
+
+; (c-e-v <proc> <nargs> <pointer-to-args>)
+
+(define-c-generator call-external-value #t
+  (lambda (call port indent)
+    (format port "((long(*)())")
+    (c-value (call-arg call 0) port)
+    (format port ")(")
+    (c-value (call-arg call 1) port)
+    (format port ", ")
+    (c-value (call-arg call 2) port)
+    (writec port #\))))
+
+
diff --git a/ps-compiler/prescheme/primop/c-primop.scm b/ps-compiler/prescheme/primop/c-primop.scm
new file mode 100644
index 0000000..36090c2
--- /dev/null
+++ b/ps-compiler/prescheme/primop/c-primop.scm
@@ -0,0 +1,29 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+; Code generation for primops.
+
+(define-record-type c-primop :c-primop
+  (make-c-primop simple? generate)
+  c-primop?
+  (simple? c-primop-simple?)
+  (generate c-primop-generate))
+
+(define (simple-c-primop? primop)
+  (c-primop-simple? (primop-code-data primop)))
+
+(define (primop-generate-c primop call port indent)
+  ((c-primop-generate (primop-code-data primop))
+   call port indent))
+
+(define-syntax define-c-generator
+  (lambda (exp r$ c$)
+    (destructure (((ignore id simple? generate) exp))
+      `(set-primop-code-data!
+	(,(r$ 'get-prescheme-primop) ',id)
+	(,(r$ 'make-c-primop)
+	 ,simple?
+	 ,generate
+	 )))))
+	 
+
diff --git a/ps-compiler/prescheme/primop/c-record.scm b/ps-compiler/prescheme/primop/c-record.scm
new file mode 100644
index 0000000..ed35565
--- /dev/null
+++ b/ps-compiler/prescheme/primop/c-record.scm
@@ -0,0 +1,42 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define-c-generator make-record #t
+  (lambda (args)
+    (bug "no eval method for MAKE-RECORD"))
+  (lambda (call depth)
+    (reconstruct-make-record call depth))
+  (lambda (call port indent)
+    (let ((type (node-type call)))
+      (write-c-coercion type port)
+      (format port "malloc(sizeof(")
+      (display-c-type (pointer-type-to type) #f port)
+      (format port ") * ")
+      (c-value (call-arg call 0) port)
+      (format port ")"))))
+      
+(define (reconstruct-make-record call depth)
+  (let* ((args (call-exp-args call))
+	 (arg-types (call-arg-types (cdr args) depth))
+	 (record-type (quote-exp-value (car args)))
+	 (type (record-type-type record-type))
+	 (maker-type (record-type-maker-type record-type)))
+    (unify! maker-type (make-arrow-type arg-types type))
+    type))
+
+(define-c-scheme-primop make-record
+  'allocate
+  (lambda (call)
+    (record-type-type (literal-value (node-ref call 0))))
+  default-simplifier)
+
+(define-scheme-primop record-ref
+  'read
+  (lambda (call)
+    (record-slot-type (literal-value (node-ref call 0))))
+  default-simplifier)
+
+(define-scheme-primop record-set!
+  'write
+  (lambda (call) type/unit)
+  default-simplifier)
diff --git a/ps-compiler/prescheme/primop/c-vector.scm b/ps-compiler/prescheme/primop/c-vector.scm
new file mode 100644
index 0000000..45959f6
--- /dev/null
+++ b/ps-compiler/prescheme/primop/c-vector.scm
@@ -0,0 +1,242 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+; (make-vector size init)
+
+(define-c-generator make-vector #t
+  (lambda (call port indent)
+    (let ((type (node-type call)))
+      (write-c-coercion type port)
+      (format port "malloc(sizeof(")
+      (display-c-type (pointer-type-to type) #f port)
+      (format port ") * ")
+      (c-value (call-arg call 0) port)
+      (format port ")"))))
+
+(define-c-generator vector-ref #t
+  (lambda (call port indent)
+    (generate-c-vector-ref (call-arg call 0) (call-arg call 1) port)))
+
+(define (generate-c-vector-ref vector index port)
+  (display "*(" port)
+  (c-value vector port)
+  (display " + " port)
+  (c-value index port)
+  (writec port #\)))
+
+(define-c-generator vector-set! #t
+  (lambda (call port indent)
+    (generate-c-vector-set (call-arg call 1)
+			   (call-arg call 2)
+			   (call-arg call 3)
+			   port indent)))
+
+(define (generate-c-vector-set vector index value port indent)
+  (indent-to port indent)
+  (generate-c-vector-ref vector index port)
+  (display " = " port)
+  (c-value value port)
+  (writec port #\;))
+
+(define-c-generator make-string #t
+  (lambda (call port indent)
+    ; calloc is used as a hack to get a zero at the end
+    (format port "(char *)calloc( 1, 1 + ")
+    (c-value (call-arg call 0) port)
+    (format port ")")))
+
+(define-c-generator string-length #t
+  (lambda (call port indent)
+    (format port "strlen((char *) ")
+    (c-value (call-arg call 0) port)
+    (format port ")")))
+
+(define-c-generator string-ref #t
+  (lambda (call port indent)
+    (generate-c-vector-ref (call-arg call 0) (call-arg call 1) port)))
+
+(define-c-generator string-set! #f
+  (lambda (call port indent)
+    (generate-c-vector-set (call-arg call 1)
+			   (call-arg call 2)
+			   (call-arg call 3)
+			   port indent)))
+
+(define-c-generator make-record #f
+  (lambda (call port indent)
+    (let ((type (get-record-type (literal-value (call-arg call 0)))))
+      (write-c-coercion type port)
+      (format port "malloc(sizeof(struct ")
+      (write-c-identifier (record-type-name type) port)
+      (format port "))"))))
+
+(define-c-generator record-ref #t
+  (lambda (call port indent)
+    (generate-c-record-ref (call-arg call 0)
+			   (call-arg call 1)
+			   (call-arg call 2)
+			   port)))
+
+(define (generate-c-record-ref record type field port)
+  (let ((field (get-record-type-field (literal-value type)
+				      (literal-value field))))
+    (c-value record port)
+    (display "->" port)
+    (write-c-identifier (record-field-name field) port)))
+
+(define-c-generator record-set! #t
+  (lambda (call port indent)
+    (generate-c-record-set (call-arg call 1)
+			   (call-arg call 2)
+			   (call-arg call 3)
+			   (call-arg call 4)
+			   port indent)))
+
+(define (generate-c-record-set record value type field port indent)
+  (indent-to port indent)
+  (generate-c-record-ref record type field port)
+  (display " = " port)
+  (c-value value port)
+  (writec port #\;))
+
+(define-c-generator allocate-memory #t
+  (lambda (call port indent)
+    (write-c-coercion type/address port)
+    (format port "malloc(") 
+    (c-value (call-arg call 0) port)
+    (format port ")")))
+
+(define-c-generator deallocate #t
+  (lambda (call port indent)
+    (format port "free(") 
+    (c-value (call-arg call 0) port)
+    (format port ")")))
+
+(define-c-generator deallocate-memory #t
+  (lambda (call port indent)
+    (format port "free(") 
+    (c-value (call-arg call 0) port)
+    (format port ")")))
+
+(define-c-generator address+ #t
+  (lambda (call port indent)
+    (simple-c-primop "+" call port)))
+  
+(define-c-generator address-difference #t
+  (lambda (call port indent)
+    (simple-c-primop "-" call port)))
+
+(define-c-generator address= #t
+  (lambda (call port indent)
+    (simple-c-primop "==" call port)))
+
+(define-c-generator address< #t
+  (lambda (call port indent)
+    (simple-c-primop "<" call port)))
+
+(define-c-generator address->integer #t
+  (lambda (call port indent)
+    (format port "((long) ") 
+    (c-value (call-arg call 0) port)
+    (format port ")")))
+
+(define-c-generator integer->address #t
+  (lambda (call port indent)
+    (format port "((char *) ") 
+    (c-value (call-arg call 0) port)
+    (format port ")")))
+
+(define-c-generator copy-memory! #t
+  (lambda (call port indent)
+    (format port "memcpy((void *)") 
+    (c-value (call-arg call 1) port)
+    (format port ", (void *)") 
+    (c-value (call-arg call 0) port)
+    (format port ",") 
+    (c-value (call-arg call 2) port)
+    (format port ")")))
+
+(define-c-generator memory-equal? #t
+  (lambda (call port indent)
+    (format port "(!memcmp((void *)") 
+    (c-value (call-arg call 1) port)
+    (format port ", (void *)") 
+    (c-value (call-arg call 0) port)
+    (format port ",") 
+    (c-value (call-arg call 2) port)
+    (format port "))")))
+
+(define-c-generator byte-ref #t
+  (lambda (call port indent)
+    (generate-c-memory-ref "unsigned char" (call-arg call 0) port)))
+
+(define-c-generator word-ref #t
+  (lambda (call port indent)
+    (generate-c-memory-ref "long" (call-arg call 0) port)))
+
+(define (generate-c-memory-ref type pointer port)
+  (format port "*((~A *) " type)
+  (c-value pointer port)
+  (writec port #\)))
+
+(define-c-generator byte-set! #t
+  (lambda (call port indent)
+    (generate-c-memory-set! "unsigned char"
+			    (call-arg call 1)
+			    (call-arg call 2)
+			    port
+			    indent)))
+
+(define-c-generator word-set! #t
+  (lambda (call port indent)
+    (generate-c-memory-set! "long"
+			    (call-arg call 1)
+			    (call-arg call 2)
+			    port
+			    indent)))
+
+(define (generate-c-memory-set! type pointer value port indent)
+  (indent-to port indent)
+  (generate-c-memory-ref type pointer port)
+  (display " = " port)
+  (c-value value port)
+  (writec port #\;))
+
+(define-c-generator char-pointer->string #t
+  (lambda (call port indent)
+    (format port "((char *)") 
+    (c-value (call-arg call 0) port)
+    (format port ")")))
+
+(define-c-generator char-pointer->nul-terminated-string #t
+  (lambda (call port indent)
+    (format port "((char *)") 
+    (c-value (call-arg call 0) port)
+    (format port ")")))
+
+(define-c-generator computed-goto #f
+  (lambda (call port indent)
+    (generate-c-switch call port indent)))
+
+(define (generate-c-switch call port indent)
+  (let ((size (call-exits call)))
+    (indent-to port indent)
+    (display "switch (" port)
+    (c-value (call-arg call (+ size 1)) port)
+    (display ") {" port)
+    (let ((indent (+ indent 2)))
+      (do ((i 0 (+ i 1))
+	   (labels (literal-value (call-arg call size)) (cdr labels)))
+	  ((>= i size))
+	(for-each (lambda (l)
+		    (indent-to port indent)
+		    (format port "case ~D : " l))
+		  (car labels))
+	(write-c-switch-case (call-arg call i) port indent)))
+    (indent-to port indent)
+    (display "}" port)))
+
+(define (write-c-switch-case node port indent)
+  (writec port #\{)
+  (write-c-block (lambda-body node) port (+ indent 2))
+  (indent-to port (+ indent 2))
+  (display "break;" port))
diff --git a/ps-compiler/prescheme/primop/io.scm b/ps-compiler/prescheme/primop/io.scm
new file mode 100644
index 0000000..a43149d
--- /dev/null
+++ b/ps-compiler/prescheme/primop/io.scm
@@ -0,0 +1,38 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+;(define-scheme-primop cast-to-long)
+
+(define-scheme-primop stdin  type/input-port)
+(define-scheme-primop stdout type/output-port)
+(define-scheme-primop stderr type/output-port)
+
+(define-nonsimple-scheme-primop read-char io)
+(define-nonsimple-scheme-primop peek-char io)
+(define-nonsimple-scheme-primop read-integer io)
+
+(define type/status type/integer)
+
+(define-nonsimple-scheme-primop write-char io)
+
+(define-scheme-primop write-string  io type/status)
+(define-scheme-primop write-integer io type/status)
+(define-scheme-primop force-output  io type/status)
+
+(define-nonsimple-scheme-primop open-input-file)
+(define-nonsimple-scheme-primop open-output-file)
+
+(define-scheme-primop close-input-port  io type/status)
+(define-scheme-primop close-output-port io type/status)
+
+(define-scheme-primop abort io type/unit)
+
+(define-nonsimple-scheme-primop error io)
+
+(define-scheme-primop error-string type/string)
+
+(define-scheme-primop call-external-value io type/integer)
+
+(define-nonsimple-scheme-primop read-block io)
+(define-scheme-primop write-block io type/status)
+
diff --git a/ps-compiler/prescheme/primop/primop.scm b/ps-compiler/prescheme/primop/primop.scm
new file mode 100644
index 0000000..2cd6ec2
--- /dev/null
+++ b/ps-compiler/prescheme/primop/primop.scm
@@ -0,0 +1,163 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define prescheme-primop-table (make-symbol-table))
+
+(walk-vector (lambda (primop)
+	       (if (primop? primop)
+		   (table-set! prescheme-primop-table
+			       (primop-id primop)
+			       primop)))
+	     all-primops)
+
+(define (get-prescheme-primop id)
+  (cond ((table-ref prescheme-primop-table id)
+	 => identity)
+	((name->enumerand id primop)
+	 => get-primop)
+	(else
+	 (bug "Scheme primop ~A not found" id))))
+
+(define (add-scheme-primop! id primop)
+  (table-set! prescheme-primop-table id primop))
+
+(define-syntax define-scheme-primop
+  (syntax-rules ()
+    ((define-scheme-primop id type)
+     (define-scheme-primop id #f type))
+    ((define-scheme-primop id side-effects type)
+     (define-scheme-primop id side-effects type default-simplifier))
+    ((define-scheme-primop id side-effects type simplifier)
+     (define-polymorphic-scheme-primop
+       id side-effects (lambda (call) type) simplifier))))
+
+(define-syntax define-polymorphic-scheme-primop
+  (syntax-rules ()
+    ((define-polymorphic-scheme-primop id type)
+     (define-polymorphic-scheme-primop id #f type))
+    ((define-polymorphic-scheme-primop id side-effects type)
+     (define-polymorphic-scheme-primop id side-effects type default-simplifier))
+    ((define-scheme-primop id side-effects type simplifier)
+     (add-scheme-primop! 'id
+			 (make-primop 'id #t 'side-effects simplifier
+				      (lambda (call) 1)
+				      type)))))
+
+(define-syntax define-nonsimple-scheme-primop
+  (syntax-rules ()
+    ((define-nonsimple-scheme-primop id)
+     (define-nonsimple-scheme-primop id #f))
+    ((define-nonsimple-scheme-primop id side-effects)
+     (define-nonsimple-scheme-primop id side-effects default-simplifier))
+    ((define-nonsimple-scheme-primop id side-effects simplifier)
+     (add-scheme-primop! 'id
+			 (make-primop 'id #f 'side-effects simplifier
+				      (lambda (call) 1)
+				      'nontrivial-primop)))))
+
+(define-syntax define-scheme-cond-primop
+  (syntax-rules ()
+    ((define-scheme-cond-primop id simplifier expand simplify?)
+     (add-scheme-primop! 'id
+			 (make-conditional-primop 'id
+						  #f
+						  simplifier
+						  (lambda (call) 1)
+						  expand
+						  simplify?)))))
+
+;(define-prescheme! 'error  ; all four args must be present if used as value
+;  (lambda (exp env)
+;    (let ((string (expand (cadr exp) env #f))
+;          (args (map (lambda (arg)
+;                       (expand arg env #f))
+;                     (cddr exp))))
+;      (make-block-exp
+;       (list
+;        (make-call-exp (get-prescheme-primop 'error)
+;                       0
+;                       type/unknown
+;                       `(,string
+;                         ,(make-quote-exp (length args) type/int32)
+;                         . ,(case (length args)
+;                              ((0)
+;                               (list (make-quote-exp 0 type/int32)
+;                                     (make-quote-exp 0 type/int32)
+;                                     (make-quote-exp 0 type/int32)))
+;                              ((1)
+;                               (list (car args)
+;                                     (make-quote-exp 0 type/int32)
+;                                     (make-quote-exp 0 type/int32)))
+;                              ((2)
+;                               (list (car args)
+;                                     (cadr args)
+;                                     (make-quote-exp 0 type/int32)))
+;                              ((3)
+;                               args)
+;                              (else
+;                               (error "too many arguments to ERROR in ~S" exp))))
+;                       exp)
+;        (make-quote-exp the-undefined-value type/unknown))))))
+
+; For the moment VALUES is more or less a macro.
+
+;(define-prescheme! 'values   ; dies if used as a value
+;  (lambda (exp env)
+;    (make-call-exp (get-prescheme-primop 'pack)
+;                   0
+;                   type/unknown
+;                   (map (lambda (arg)
+;                          (expand arg env #f))
+;                        (cdr exp))
+;                   exp)))
+
+; Each arg spec is either #F = non-continuation argument or a list of
+; variable (name . type)s for the continuation.
+
+;(define (define-continuation-expander id primop-id arg-specs)
+;  (define-primitive-expander id (length arg-specs)
+;    (lambda (source args cenv)
+;      (receive (conts other)
+;          (expand-arguments args arg-specs cenv)
+;        (make-call-exp (get-prescheme-primop primop-id)
+;                       (length conts)
+;                       type/unknown
+;                       (append conts other)
+;                       source)))))
+
+;(define (expand-arguments args specs cenv)
+;  (let loop ((args args) (specs specs) (conts '()) (other '()))
+;    (if (null? args)
+;        (values (reverse conts) (reverse other))
+;        (let ((arg (expand (car args) cenv #f)))
+;          (if (not (car specs))
+;              (loop (cdr args) (cdr specs) conts (cons arg other))
+;              (loop (cdr args) (cdr specs)
+;                    (cons (expand-continuation-arg arg (car specs))
+;                          conts)
+;                    other))))))                                            
+;
+;(define (expand-continuation-arg arg var-specs)
+;  (let* ((vars (map (lambda (p)
+;                      (make-variable (car p) (cdr p)))
+;                    var-specs)))
+;    (make-continuation-exp
+;     vars
+;     (make-call-exp (get-primop (enum primop unknown-call))
+;                    0
+;                    type/unknown
+;                    `(,arg
+;                      ,(make-quote-exp (length vars) #f)
+;                      . ,vars)
+;                    #f)))) ; no source
+
+; Randomness needed by both arith.scm and c-arith.scm.
+
+; What we will get in C.
+(define prescheme-integer-size 32)
+
+(define int-mask (- (arithmetic-shift 1 prescheme-integer-size) 1))
+
+(define (lshr i n)
+  (arithmetic-shift (bitwise-and i int-mask) (- 0 n)))
+
diff --git a/ps-compiler/prescheme/primop/scm-arith.scm b/ps-compiler/prescheme/primop/scm-arith.scm
new file mode 100644
index 0000000..ddc565b
--- /dev/null
+++ b/ps-compiler/prescheme/primop/scm-arith.scm
@@ -0,0 +1,187 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+; Arithmetic inference rules
+
+(define (arith-op-rule args node depth return?)
+  (for-each (lambda (arg)
+	      (unify! (infer-type arg depth) type/integer node))
+	    args)
+  type/integer)
+
+(define (arith-comparison-rule args node depth return?)
+  (arith-op-rule args node depth return?)
+  type/boolean)
+
+(define (integer-binop-rule args node depth return?)
+  (check-arg-type args 0 type/integer depth node)
+  (check-arg-type args 1 type/integer depth node)
+  type/integer)
+
+(define (integer-monop-rule args node depth return?)
+  (check-arg-type args 0 type/integer depth node)
+  type/integer)
+
+(define (integer-comparison-rule args node depth return?)
+  (check-arg-type args 0 type/integer depth node)
+  type/boolean)
+
+;----------------------------------------------------------------
+; Arithmetic
+
+(define-complex-primitive (+ . integer?) +
+  arith-op-rule
+  (lambda (x y) (+ x y))
+  (lambda (args type)
+    (if (null? args)
+	(make-literal-node 0 type/integer)
+	(n-ary->binary args
+		       (make-literal-node (get-prescheme-primop '+))
+		       type))))
+
+(define-complex-primitive (* . integer?) *
+  arith-op-rule
+  (lambda (x y) (* x y))
+  (lambda (args type)
+    (if (null? args)
+	(make-literal-node 1)
+	(n-ary->binary args
+		       (make-literal-node (get-prescheme-primop '*))
+		       type))))
+
+(define-complex-primitive (- integer? . integer?)
+  (lambda args
+    (if (or (null? (cdr args))
+	    (null? (cddr args)))
+	(apply - args)
+	(user-error "error while evaluating: type error ~A" (cons '- args))))
+  (lambda (args node depth return?)
+    (case (length args)
+      ((1)
+       (check-arg-type args 0 type/integer depth node)
+       type/integer)
+      ((2)
+       (check-arg-type args 0 type/integer depth node)
+       (check-arg-type args 1 type/integer depth node)
+       type/integer)
+      (else
+       (user-error "wrong number of arguments to - in ~S" (schemify node)))))
+  (lambda (x y) (- x y))
+  (lambda (args type)
+    (let ((primop (get-prescheme-primop '-)))
+      (if (null? (cdr args))
+	  (make-primop-call-node primop
+				 (list (make-literal-node 0) (car args))
+				 type)
+	  (make-primop-call-node primop args type)))))
+
+(define (n-ary->binary args proc type)
+  (let loop ((args args))
+    (if (null? (cdr args))
+	(car args)
+	(loop (cons (make-call-node proc
+				    (list (car args) (cadr args))
+				    type)
+		    (cddr args))))))
+
+(define-syntax define-binary-primitive
+  (syntax-rules ()
+    ((define-binary-primitive id type-reconstruct)
+     (define-complex-primitive (id integer? integer?) id
+       type-reconstruct
+       (lambda (x y) (id x y))
+       (lambda (args type)
+	 (make-primop-call-node (get-prescheme-primop 'id) args type))))))
+
+(define-binary-primitive = arith-comparison-rule)
+(define-binary-primitive < arith-comparison-rule)
+
+(define-semi-primitive (>  integer? integer?) >
+  arith-comparison-rule
+  (lambda (x y) (< y x)))
+
+(define-semi-primitive (<= integer? integer?) <=
+  arith-comparison-rule
+  (lambda (x y) (not (< y x))))
+
+(define-semi-primitive (>= integer? integer?) >=
+  arith-comparison-rule
+  (lambda (x y) (not (< x y))))
+
+(define-binary-primitive quotient  integer-binop-rule)
+(define-binary-primitive remainder integer-binop-rule)
+(define-binary-primitive modulo    integer-binop-rule)
+
+(define-primitive bitwise-and
+  ((integer? type/integer) (integer? type/integer))
+  type/integer)
+
+(define-primitive bitwise-ior
+  ((integer? type/integer) (integer? type/integer))
+  type/integer)
+
+(define-primitive bitwise-xor
+  ((integer? type/integer) (integer? type/integer))
+  type/integer)
+
+(define-primitive bitwise-not
+  ((integer? type/integer))
+  type/integer)
+
+(define-primitive shift-left
+  ((integer? type/integer) (integer? type/integer))
+  type/integer
+  ashl)
+
+(define-primitive logical-shift-right
+  ((integer? type/integer) (integer? type/integer))
+  type/integer
+  lshr)
+
+(define-primitive arithmetic-shift-right
+  ((integer? type/integer) (integer? type/integer))
+  type/integer
+  ashr)
+
+(define-semi-primitive (abs integer?) abs
+  arith-op-rule
+  (lambda (n) (if (< n 0) (- 0 n) n)))
+
+(define-semi-primitive (zero? integer?) zero?
+  arith-comparison-rule
+  (lambda (n) (= n 0)))
+
+(define-semi-primitive (positive? integer?) positive?
+  arith-comparison-rule
+  (lambda (n) (< 0 n)))
+
+(define-semi-primitive (negative? integer?) negative?
+  arith-comparison-rule
+  (lambda (n) (< n 0)))
+
+(define-semi-primitive (even? integer?) even?
+  integer-comparison-rule
+  (lambda (n) (= 0 (remainder n 2))))
+
+(define-semi-primitive (odd? integer?) odd?
+  integer-comparison-rule
+  (lambda (n) (not (even? n))))
+  
+(define-semi-primitive (max integer? . integer?) max
+  arith-op-rule
+  (lambda (x y)
+    (if (< x y) y x)))
+  
+(define-semi-primitive (min integer? . integer?) min
+  arith-op-rule
+  (lambda (x y)
+    (if (< x y) x y)))
+
+(define-semi-primitive (expt integer? positive-integer?) expt
+  arith-op-rule
+  (lambda (x y)
+    (do ((r x (* r x))
+	 (y y (- y 1)))
+	((<= y 0)
+	 r))))
+
diff --git a/ps-compiler/prescheme/primop/scm-memory.scm b/ps-compiler/prescheme/primop/scm-memory.scm
new file mode 100644
index 0000000..18f2eb9
--- /dev/null
+++ b/ps-compiler/prescheme/primop/scm-memory.scm
@@ -0,0 +1,122 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define-primitive allocate-memory ((positive-integer? type/integer)) type/address)
+(define-primitive deallocate-memory ((address? type/address)) type/unit)
+
+(define-load-time-primitive (address? #f) address?)
+
+(define-primitive address+ 
+  ((address? type/address)
+   (integer? type/integer))
+  type/address)
+
+(define-semi-primitive (address- address? integer?) address-
+  (lambda (args node depth return?)
+    (check-arg-type args 0 type/address depth node)
+    (check-arg-type args 1 type/integer depth node)
+    type/address)
+  (lambda (x y) (address+ x (- 0 y))))
+
+(define-primitive address-difference
+  ((address? type/address)
+   (address? type/address))
+  type/integer)
+
+(define-primitive address=
+  ((address? type/address)
+   (address? type/address))
+  type/boolean)
+
+(define-primitive address<
+  ((address? type/address)
+   (address? type/address))
+  type/boolean)
+
+(define-prescheme! 'null-address
+  (let ((location (make-undefined-location 'null-address)))
+    (set-contents! location (make-external-value "NULL" type/address))
+    location)
+  #f)
+
+(define-semi-primitive (null-address? address?) null-address?
+  (lambda (args node depth return)
+    (check-arg-type args 0 type/address depth node)
+    type/boolean)
+  (lambda (x) (address= x null-address)))
+
+(define (address-comparison-rule args node depth return?)
+  (check-arg-type args 0 type/address depth node)
+  (check-arg-type args 1 type/address depth node)
+  type/boolean)
+
+(define-semi-primitive (address> address? address?) address>
+  address-comparison-rule
+  (lambda (x y) (address< y x)))
+
+(define-semi-primitive (address<= address? address?) address<=
+  address-comparison-rule
+  (lambda (x y) (not (address< y x))))
+
+(define-semi-primitive (address>= address? address?) address>=
+  address-comparison-rule
+  (lambda (x y) (not (address< x y))))
+
+(define-primitive address->integer
+  ((address? type/address))
+  type/integer)
+   
+(define-primitive integer->address
+  ((integer? type/integer))
+  type/address)
+
+(define-primitive copy-memory! 
+  ((address? type/address)
+   (address? type/address)
+   (positive-integer? type/integer))
+  type/unit)
+
+(define-primitive memory-equal? 
+  ((address? type/address)
+   (address? type/address)
+   (positive-integer? type/integer))
+  type/boolean)
+
+(define-primitive unsigned-byte-ref
+  ((address? type/address))
+  type/integer
+  byte-ref)
+
+(define-primitive unsigned-byte-set!
+  ((address? type/address) (unsigned-byte? type/integer))
+  type/unit
+  byte-set!)
+
+(define-primitive word-ref ((address? type/address)) type/integer)
+(define-primitive word-set!
+  ((address? type/address) (positive-integer? type/integer))
+  type/unit)
+
+(define-primitive char-pointer->string
+  ((address? type/address)
+   (positive-integer? type/integer))
+  type/string)
+
+(define-primitive char-pointer->nul-terminated-string
+  ((address? type/address))
+  type/string)
+
+(let ((read-block-return-type
+       (make-tuple-type (list type/integer type/boolean type/status))))
+  (define-primitive read-block
+    ((input-port? type/input-port)
+     (address? type/address)
+     (positive-integer? type/integer))
+    read-block-return-type))
+  
+(define-primitive write-block
+  ((output-port? type/output-port)
+   (address? type/address)
+   (positive-integer? type/integer))
+  type/status)
+
diff --git a/ps-compiler/prescheme/primop/scm-record.scm b/ps-compiler/prescheme/primop/scm-record.scm
new file mode 100644
index 0000000..d6360b0
--- /dev/null
+++ b/ps-compiler/prescheme/primop/scm-record.scm
@@ -0,0 +1,46 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define-complex-primitive (make-record symbol?)
+  (lambda (type)
+    (bug "no evaluator for MAKE-RECORD"))
+  (lambda (args node depth return?)
+    (let ((type-id (cadr (node-form (car args)))))
+      (make-pointer-type (get-record-type type-id))))
+  #f  ; no closed form
+  (lambda (args type)
+    (make-primop-call-node (get-prescheme-primop 'make-record) args type)))
+
+(define-complex-primitive (record-ref any?  ; no RECORD? available
+				      symbol? symbol?)
+  (lambda (thing type field)
+    (bug "no evaluator for RECORD-REF"))
+  (lambda (args node depth return?)
+    (let ((type-id (cadr (node-form (cadr args))))
+	  (field-id (cadr (node-form (caddr args)))))
+      (let ((record-type (make-pointer-type (get-record-type type-id)))
+	    (field-type (record-field-type
+			 (get-record-type-field type-id field-id))))
+	(check-arg-type args 0 record-type depth node)
+	field-type)))
+  #f  ; no closed form
+  (lambda (args type)
+    (make-primop-call-node (get-prescheme-primop 'record-ref) args type)))
+
+(define-complex-primitive (record-set! any?  ; no RECORD? available
+				       any? symbol? symbol?)
+  (lambda (thing value type field)
+    (bug "no evaluator for RECORD-SET!"))
+  (lambda (args node depth return?)
+    (let ((type-id (cadr (node-form (caddr args))))
+	  (field-id (cadr (node-form (cadddr args)))))
+      (let ((record-type (make-pointer-type (get-record-type type-id)))
+	    (field-type (record-field-type
+			 (get-record-type-field type-id field-id))))
+	(check-arg-type args 0 record-type depth node)
+	(check-arg-type args 1 field-type depth node)
+	type/unit)))
+  #f  ; no closed form
+  (lambda (args type)
+    (make-primop-call-node (get-prescheme-primop 'record-set!) args type)))
+
diff --git a/ps-compiler/prescheme/primop/scm-scheme.scm b/ps-compiler/prescheme/primop/scm-scheme.scm
new file mode 100644
index 0000000..0db036a
--- /dev/null
+++ b/ps-compiler/prescheme/primop/scm-scheme.scm
@@ -0,0 +1,403 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+; Primitives that directly correspond to primops.
+;
+; (define-primitive (id (arg-pred arg-type) ...) result-type . maybe-primop-id)
+;
+; Primitives that are n-ary or have other weirdness.
+;
+; (define-complex-primitive (id . argument-predicates)
+;   eval-fn inference-rule source . maybe-expander)
+;
+; Primitives that have only source but not a primop.
+;
+; (define-semi-primitive (id . argument-predicates)
+;   eval-fn inference-rule source maybe-expander)
+;
+; Primitives available only at load time.
+;
+; (define-load-time-primitive (id . argument-predicates) eval-fn)
+
+; (really-define-primitive (id . argument-predicates)
+;   eval-fn inference-rule source expander expands-in-place?)
+
+(define-syntax really-define-primitive
+  (lambda (exp r c)
+    (let* ((spec (cadr exp))
+	   (id (car spec))
+	   (arg-predicates (cdr spec))
+	   (eval (caddr exp))
+	   (rest (cdddr exp))
+	   (inference-rule (car rest))
+	   (source (cadr rest))
+	   (expander (caddr rest))
+	   (expands-in-place? (cadddr rest)))
+      `(let ((,(r 'predicates) ,(let recur ((preds arg-predicates))
+				  (cond ((pair? preds)
+					 `(cons ,(car preds)
+						,(recur (cdr preds))))
+					((null? preds)
+					 '(quote ()))
+					(else
+					 preds)))))
+	 (define-prescheme! ',id
+	   #f				; location
+	   (make-primitive ',id
+			   ,(r 'predicates)
+			   ,eval
+			   ',source
+			   ,expander
+			   ,expands-in-place?
+			   ,inference-rule))))))
+
+(define-syntax define-complex-primitive
+  (lambda (exp r c)
+    `(really-define-primitive ,@(cdr exp) #t)))
+
+(define-syntax define-primitive
+  (lambda (exp r c)
+    (let* ((id (cadr exp))
+	   (args (caddr exp))
+	   (result (cadddr exp))
+	   (primop (if (null? (cddddr exp)) (cadr exp) (car (cddddr exp))))
+	   (names (map (lambda (a b) b)
+		       args
+		       '(x1 x2 x3 x4 x5 x6 x7 x8 x9))))
+      `(define-complex-primitive (,id . ,(map car args)) ,id
+	 (lambda (args node depth return?)
+	   (if (not (= (length args)
+		       ,(length args)))
+	       (user-error "wrong number of arguments in ~S" (schemify node)))
+	   ,@(do ((i 0 (+ i 1))
+		  (args args (cdr args))
+		  (res '() (cons `(check-arg-type args ,i ,(cadar args) depth node)
+				 res)))
+		 ((null? args)
+		  (reverse res)))
+	   ,result)
+	 (lambda ,names (,id . ,names))
+	 (lambda (args type)
+	   (make-primop-call-node (get-prescheme-primop ',primop) args type))))))
+
+(define-syntax define-semi-primitive
+  (lambda (exp r c)
+    `(really-define-primitive ,@(cdr exp) #f #f)))
+
+(define-syntax define-load-time-primitive
+  (lambda (exp r c)
+    `(define-semi-primitive ,(cadr exp)
+       ,(caddr exp)
+       (make-load-time-only-rule ',(caadr exp))
+       #f)))
+
+(define (make-load-time-only-rule id)
+  (lambda (args node depth return?)
+    (user-error "~S is only available at load time ~S" id (schemify node))))
+   
+;----------------------------------------------------------------
+; Boolean stuff
+
+(define-semi-primitive (not #f) not
+  (lambda (args node depth return?)
+    (check-arg-type args 0 type/boolean depth node)
+    type/boolean)
+  (lambda (x) (if x #f #t)))
+
+(define-load-time-primitive (boolean? #f) boolean?)
+
+(define-complex-primitive (eq? #f #f) eq?
+  (lambda (args node depth return?)
+    (unify! (infer-type (car args) depth)
+	    (infer-type (cadr args) depth)
+	    node)
+    type/boolean)
+  (lambda (x y) (eq? x y))
+  (lambda (args type)
+    (make-primop-call-node (get-prescheme-primop 'eq?) args type)))
+
+(define-load-time-primitive (eqv? #f) eqv?)
+(define-load-time-primitive (equal? #f) equal?)
+
+;----------------------------------------------------------------
+; Characters
+
+(define (ascii-value? n)
+  (and (integer? n)
+       (>= n 0)
+       (< n ascii-limit)))
+
+(define-primitive ascii->char ((ascii-value? type/integer)) type/char)
+(define-primitive char->ascii ((char? type/char)) type/integer)
+    
+(define (char-comparison-rule args node depth return?)
+  (check-arg-type args 0 type/char depth node)
+  (check-arg-type args 1 type/char depth node)
+  type/boolean)
+
+(define-syntax define-char-comparison
+  (lambda (exp r c)
+    (let ((id (cadr exp))
+	  (op (caddr exp)))
+      `(define-complex-primitive (,id char? char?) ,id
+	 char-comparison-rule
+	 (lambda (x y) (,op x y))
+	 (lambda (args type)
+	   (make-primop-call-node (get-prescheme-primop ',op) args type))))))
+
+(define-char-comparison char=? =)
+(define-char-comparison char<? <)
+(define-char-comparison char>? >)
+(define-char-comparison char<=? <=)
+(define-char-comparison char>=? >=)
+
+; Plus lots more...
+
+;----------------------------------------------------------------
+; Data manipulation
+
+(define (any? x) #t)
+
+(define (positive-integer? x)
+  (and (integer? x)
+       (<= 0 x)))
+
+(define (unsigned-byte? x)
+  (and (positive-integer? x)
+       (<= x 256)))
+
+(define-complex-primitive (make-vector positive-integer? . any?) make-vector
+  (lambda (args node depth return?)
+    (let ((uvar (make-uvar 'v depth)))
+      (make-nonpolymorphic! uvar)
+      (check-arg-type args 0 type/integer depth node)
+      (check-arg-type args 1 uvar         depth node)
+      (make-pointer-type uvar)))
+  (lambda (size init)
+    (make-vector size init))
+  (lambda (args type)
+    (make-primop-call-node (get-prescheme-primop 'make-vector) args type)))
+
+(define-load-time-primitive (vector-length vector?) vector-length)
+
+(define-complex-primitive (vector-ref vector? positive-integer?) vector-ref
+  (lambda (args node depth return?)
+    (let ((elt-type (make-uvar 'v depth)))
+      (check-arg-type args 0 (make-pointer-type elt-type) depth node)
+      (check-arg-type args 1 type/integer depth node)
+      elt-type))
+  (lambda (vector index)
+    (vector-ref vector index))
+  (lambda (args type)
+    (make-primop-call-node (get-prescheme-primop 'vector-ref) args type)))
+
+(define-complex-primitive (vector-set! vector? positive-integer? any?)
+  vector-set!
+  (lambda (args node depth return?)
+    (let ((elt-type (make-uvar 'v depth)))
+      (check-arg-type args 0 (make-pointer-type elt-type) depth node)
+      (check-arg-type args 1 type/integer depth node)
+      (check-arg-type args 2 elt-type depth node)
+      type/unit))
+  (lambda (vector index value)
+    (vector-set! vector index value))
+  (lambda (args type)
+    (make-primop-call-node (get-prescheme-primop 'vector-set!) args type)))
+
+(define-primitive make-string ((integer? type/integer)) type/string)
+(define-primitive string-length ((string? type/string)) type/integer)
+
+(define-primitive string-ref
+  ((string? type/string) (integer? type/integer))
+  type/char)
+
+(define-primitive string-set!
+  ((string? type/string) (integer? type/integer) (char? type/char))
+  type/unit)
+
+(define-complex-primitive (deallocate any?) (lambda (x) (values))
+  (lambda (args node depth return?)
+    (let ((type (make-pointer-type (make-uvar 'p depth))))
+      (check-arg-type args 0 type depth node)
+      type/unit))
+  (lambda (thing)
+    (deallocate thing))
+  (lambda (args type)
+    (make-primop-call-node (get-prescheme-primop 'deallocate) args type)))
+
+(define-complex-primitive (null-pointer? any?) (lambda (x) #f)
+  (lambda (args node depth return?)
+    (let ((type (make-pointer-type (make-uvar 'p depth))))
+      (check-arg-type args 0 type depth node)
+      type/boolean))
+  (lambda (thing)
+    (null-pointer? thing))
+  (lambda (args type)
+    (make-primop-call-node (get-prescheme-primop 'null-pointer?) args type)))
+
+(define-complex-primitive (null-pointer) (lambda () #f)
+  (lambda (args node depth return?)
+    (make-pointer-type (make-uvar 'null depth)))
+  (lambda ()
+    (null-pointer))
+  (lambda (args type)
+    (make-primop-call-node (get-prescheme-primop 'null-pointer) args type)))
+
+;----------------------------------------------------------------
+; I/O
+
+(define-primitive current-input-port  () type/input-port  stdin)
+(define-primitive current-output-port () type/output-port stdout)
+(define-primitive current-error-port  () type/output-port stderr)
+
+(define type/status type/integer)
+
+(let ((return (make-tuple-type (list type/input-port type/status))))
+  (define-primitive open-input-file ((string? type/string)) return))
+
+(let ((return (make-tuple-type (list type/output-port type/status))))
+  (define-primitive open-output-file ((string? type/string)) return))
+
+(define-primitive close-input-port ((input-port? type/input-port)) type/status)
+(define-primitive close-output-port ((output-port? type/output-port)) type/status)
+
+(define char-return-type
+  (make-tuple-type (list type/char type/boolean type/status)))
+
+(define-primitive read-char ((input-port? type/input-port)) char-return-type)
+(define-primitive peek-char ((input-port? type/input-port)) char-return-type)
+
+(define integer-return-type
+  (make-tuple-type (list type/integer type/boolean type/status)))
+
+(define-primitive read-integer ((input-port? type/input-port)) integer-return-type)
+
+(define-primitive write-char
+  ((char? type/char) (output-port? type/output-port))
+  type/status)
+
+(define-primitive write-string
+  ((string? type/string) (output-port? type/output-port))
+  type/status)
+
+(define-primitive write-integer
+  ((integer? type/integer) (output-port? type/output-port))
+  type/status)
+
+(define-complex-primitive (newline output-port?) newline
+  (lambda (args node depth return?)
+    (check-arg-type args 0 type/output-port depth node)
+    type/status)
+  (lambda (out)
+    (write-char #\newline out))
+  (lambda (args type)
+    (make-primop-call-node (get-prescheme-primop 'write-char)
+			   (cons (make-literal-node #\newline) args)
+			   type)))
+
+(define-primitive force-output ((output-port? type/output-port)) type/status)
+
+(define-primitive error-string
+  ((positive-integer? type/status))
+  type/string)
+
+;----------------------------------------------------------------
+
+(define-complex-primitive (values . any?) values
+  (lambda (args node depth return?)
+    (make-tuple-type (infer-types args depth)))
+  #f
+  (lambda (args type)
+    (let ((node (make-node values-operator (cons 'values args))))
+      (node-set! node 'type type)
+      node)))
+
+(define values-operator (get-operator 'values))
+
+; CALL-WITH-VALUES that uses closures instead of procedures.
+
+(define (ps-call-with-values producer consumer)
+  (call-with-values
+   (lambda ()
+     (apply-closure producer '()))
+   (lambda args
+     (apply-closure consumer args))))
+
+(define-complex-primitive (call-with-values closure? closure?)
+  ps-call-with-values
+  (lambda (args node depth return?)
+    (if (not (lambda-node? (cadr args)))
+	(user-error
+	 "second argument to CALL-WITH-VALUES must be a lambda node~%  ~S"
+	 (schemify node)))
+    (let* ((consumer-type (infer-type (cadr args) depth))
+	   (arg-types (arrow-type-args consumer-type))
+	   (result-type (arrow-type-result consumer-type)))
+      (unify! (infer-type (car args) depth)
+	      (make-arrow-type '() (make-tuple-type arg-types))
+	      node)
+      (if (not return?)  ; so we cause a check for illegal tuples
+	  (unify! result-type (make-uvar 'temp depth) node))
+      result-type))
+  #f
+  (lambda (args type)
+    (let* ((tuple-type (arrow-type-result
+ 			 (maybe-follow-uvar (node-ref (car args) 'type))))
+	   (node (make-node call-with-values-operator
+			    (list 'call-with-values
+				  (make-call-node (car args) '() tuple-type)
+				  (cadr args)))))
+      (node-set! node 'type type)
+      node)))
+
+(define lambda-node? (node-predicate 'lambda))
+
+(define call-with-values-operator (get-operator 'call-with-values))
+
+(define-primitive unspecific () type/unit)
+
+(define-complex-primitive (error string? . integer?) error
+  (lambda (args node depth return?)
+    (check-arg-type args 0 type/string depth node)
+    (do ((args (cdr args) (cdr args)))
+	((null? args))
+      (check-arg-type args 0 type/integer depth node))
+    type/null)
+  (lambda (error string)
+    (error string))
+  (lambda (args type)
+    (make-primop-call-node (get-prescheme-primop 'error) args type)))
+
+; For enumerated types that are shared with C
+
+(define-load-time-primitive (make-external-constant symbol? symbol? string?)
+  make-external-constant)
+
+;----------------------------------------------------------------
+; Utilities for making nodes
+
+(define call-operator (get-operator 'call))
+(define literal-operator (get-operator 'literal))
+(define name-operator (get-operator 'name))
+(define primitive-operator (get-operator 'primitive))
+
+(define (make-call-node proc args type)
+  (let ((node (make-node call-operator (cons proc args))))
+    (node-set! node 'type type)
+    node))
+
+(define (make-literal-node value)
+  (make-node literal-operator value))
+
+(define (make-primop-call-node primop args type)
+  (make-call-node (make-literal-node primop) args type))
+
+(define (make-reference-node id binding)
+  (let ((node (make-node name-operator id)))
+    (node-set! node 'binding binding)
+    node))
+
+(define (var->name-node var)
+  (make-reference-node ((structure-ref variable variable-name) var)
+		       (make-binding #f var #f)))
+
diff --git a/ps-compiler/prescheme/primop/vector.scm b/ps-compiler/prescheme/primop/vector.scm
new file mode 100644
index 0000000..5edb734
--- /dev/null
+++ b/ps-compiler/prescheme/primop/vector.scm
@@ -0,0 +1,82 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+(define-polymorphic-scheme-primop make-vector allocate
+  (lambda (call)
+    (make-pointer-type (node-type (call-arg call 1)))))
+
+(define-polymorphic-scheme-primop vector-ref read
+  (lambda (call)
+    (pointer-type-to (node-type (call-arg call 0)))))
+
+(define-nonsimple-scheme-primop vector-set! write)
+
+(define-scheme-primop make-string   allocate type/string)
+(define-scheme-primop string-length          type/integer)
+(define-scheme-primop string-ref    read     type/char)
+
+(define-nonsimple-scheme-primop string-set! write)
+
+(define-polymorphic-scheme-primop make-record allocate
+  (lambda (call)
+    (literal-value (call-arg call 1))))
+
+(define-polymorphic-scheme-primop record-ref read
+  (lambda (call)
+    (record-field-type (literal-value (call-arg call 1)))))
+
+(define-nonsimple-scheme-primop record-set! write)
+
+(define-scheme-primop deallocate        deallocate type/unit)
+(define-scheme-primop allocate-memory   allocate   type/address)
+(define-scheme-primop deallocate-memory deallocate type/unit)
+
+(define (simplify-address+ call)
+  (simplify-args call 0)
+  ((pattern-simplifier
+    ((address+ a '0) a)
+    ((address+ (address+ a x) y) (address+ a (+ x y))))
+   call))
+
+(define-scheme-primop address+ #f type/address simplify-address+)
+
+(define-scheme-primop address-difference type/address)
+(define-scheme-primop address=           type/boolean)
+(define-scheme-primop address<           type/boolean)
+(define-scheme-primop address->integer   type/integer)
+(define-scheme-primop integer->address   type/address)
+
+(define-scheme-primop copy-memory!  write type/unit)
+(define-scheme-primop memory-equal?       type/boolean)
+(define-scheme-primop byte-ref      read  type/integer)
+(define-scheme-primop word-ref      read  type/integer)
+
+(define-nonsimple-scheme-primop byte-set! write)
+(define-nonsimple-scheme-primop word-set! write)
+
+; We delete the length argument because we don't need it.  This is allowable
+; because trivial calls can't have WRITE side effects.
+
+(define-scheme-primop char-pointer->string #f type/string
+  (lambda (call)
+    (if (= 2 (call-arg-count call))
+	(remove-call-arg call 1))))
+
+(define-scheme-primop char-pointer->nul-terminated-string type/string)
+
+; (COMPUTED-GOTO <exit0> <exit1> ... <exitN> <dispatch-value>)
+
+; Remove an unecessary coercion on the dispatch-value, if possible.
+
+(define (simplify-computed-goto call)
+  (simplify-args call 0)
+  (let ((value (call-arg call (call-exits call))))
+    (cond ((and (call-node? value)
+		(eq? 'coerce (primop-id (call-primop value)))
+		(< (call-exits call) 256)
+		(eq? type/integer (literal-value (call-arg value 1))))
+	   (replace value (detach (call-arg value 0)))))))
+
+(define-nonsimple-scheme-primop computed-goto #f simplify-computed-goto)
+
+
+
diff --git a/ps-compiler/prescheme/ps-syntax.scm b/ps-compiler/prescheme/ps-syntax.scm
new file mode 100644
index 0000000..a7e08ce
--- /dev/null
+++ b/ps-compiler/prescheme/ps-syntax.scm
@@ -0,0 +1,116 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+; Redefine CASE so that it doesn't call MEMV
+
+(define-syntax case
+  (lambda (e r c)
+    (let ((x (r 'x))
+	  (xlet (r 'let))
+	  (xcond (r 'cond))
+	  (xif (r 'if))
+	  (xeq? (r 'eq?))
+	  (xquote (r 'quote)))
+      (let ((test (lambda (y)
+		    `(,xeq? ,x (,xquote ,y)))))
+	`(,xlet ((,x ,(cadr e)))
+		(,xcond . ,(map (lambda (clause)
+				  (if (c (car clause) 'else)
+				      clause
+				      `(,(let label ((xs (car clause)))
+					   (cond ((null? xs) #f)
+						 ((null? (cdr xs))
+						  (test (car xs)))
+						 (else
+						  `(,xif ,(test (car xs))
+							 #t
+							 ,(label (cdr xs))))))
+					. ,(cdr clause))))
+				(cddr e))))))))
+
+; RECEIVE (from big-scheme)
+
+(define-syntax receive
+  (syntax-rules ()
+    ((receive ?vars ?producer . ?body)
+     (call-with-values (lambda () ?producer)
+		       (lambda ?vars . ?body)))))
+
+
+(define-syntax external
+  (lambda (e r c)
+    (let ((l (length e)))
+      (if (and (or (= l 3) (= l 4))
+	       (string? (cadr e)))
+	  `(,(r 'real-external) ,(cadr e) ',(caddr e))
+	  e))))
+
+; DEFINE-EXTERNAL-ENUMERATION (from prescheme)
+
+(define-syntax define-external-enumeration
+  (lambda (form rename compare)
+    (let* ((name (cadr form))
+	   (symbol->upcase-string
+	    (lambda (s)
+	      (list->string (map (lambda (c)
+				   (if (char=? c #\-)
+				       #\_
+				       (char-upcase c)))
+				 (string->list (symbol->string s))))))
+	   (constant
+	    (lambda (sym string)
+	      `(,(rename 'make-external-constant) ',name ',sym ,string)))
+	   (conc (lambda things
+		   (string->symbol (apply string-append
+					  (map (lambda (thing)
+						 (if (symbol? thing)
+						     (symbol->string thing)
+						     thing))
+					       things)))))
+	   (var-name
+	    (lambda (sym)
+	      (conc name "/" sym)))
+	   (components
+	    (list->vector
+	     (map (lambda (stuff)
+		    (if (pair? stuff)
+			(cons (car stuff)
+			      (var-name (car stuff)))
+			(cons stuff
+			      (var-name stuff))))
+		  (caddr form))))
+	   (%define (rename 'define))
+	   (%define-syntax (rename 'define-syntax))
+	   (%begin (rename 'begin))
+	   (%quote (rename 'quote))
+	   (%make-external-constant (rename 'make-external-constant))
+	   (e-name (conc name '- 'enumeration))
+	   (count (vector-length components)))
+      `(,%begin
+	(,%define-syntax ,name
+	    (let ((components ',components))
+	      (lambda (e r c)
+		(let ((key (cadr e)))
+		  (cond ((c key 'enum)
+			 (let ((which (caddr e)))
+			   (let loop ((i 0)) ;vector-posq
+			     (if (< i ,count)
+				 (if (c which (car (vector-ref components i)))
+				     (r (cdr (vector-ref components i)))
+				     (loop (+ i 1)))
+				 ;; (syntax-error "unknown enumerand name"
+				 ;;               `(,(cadr e) ,(car e) ,(caddr e)))
+				 e))))
+			(else e))))))
+	(,%define ,(conc name '- 'count) ,count)
+        . ,(map (lambda (stuff)
+		  (if (pair? stuff)
+		      `(,%define ,(var-name (car stuff))
+			   (,%make-external-constant ',name
+						     ',(car stuff)
+						     ,(cadr stuff)))
+		      `(,%define ,(var-name stuff)
+			   (,%make-external-constant ',name
+						     ',stuff
+						     ,(symbol->upcase-string stuff)))))
+		(caddr form)))))
+    (begin define define-syntax quote external make-external-constant))
diff --git a/ps-compiler/prescheme/record.scm b/ps-compiler/prescheme/record.scm
new file mode 100644
index 0000000..1dbe329
--- /dev/null
+++ b/ps-compiler/prescheme/record.scm
@@ -0,0 +1,122 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+; Records that translate into C structs.
+
+; Representation of records types.
+
+(define-record-type record-type
+  (name)
+  (fields              ; filled in later because of circularity
+   constructor-args)   ; fields passed to the constructor
+  )
+
+(define-record-discloser type/record-type
+  (lambda (rtype)
+    (list 'record-type (record-type-name rtype))))
+
+; Fields of record types.
+
+(define-record-type record-field
+  (record-type
+   name
+   type
+   )
+  ())
+
+; Global table of record types.  Since we compile to a single C file the
+; record types used within a single computation must have distinct names.
+; (This should really be a fluid.)
+
+(define *record-type-table* (make-symbol-table))
+
+(define (reset-record-data!)
+  (set! *record-type-table* (make-symbol-table)))
+
+(define (get-record-type id)
+  (cond ((table-ref *record-type-table* id)
+	 => identity)
+	(else
+	 (error "no record type ~S" id))))
+
+(define (lookup-record-type id)
+  (table-ref *record-type-table* id))
+
+(define (all-record-types)
+  (table->entry-list *record-type-table*))
+
+; Construction a record type.  This gets the name, the list of fields whose
+; initial values are passed to the constructor, and the field specifications.
+; Each field specification consists of a name and a type.
+
+(define (make-record-type id constructor-args specs)
+  (let ((rt (record-type-maker id)))
+    (if (table-ref *record-type-table* id)
+	(user-error "multiple definitions of record type ~S" id))
+    (table-set! *record-type-table* id rt)
+    (set-record-type-fields! rt (map (lambda (spec)
+				       (record-field-maker
+					  rt
+					  (car spec)
+					  (expand-type-spec (cadr spec))))
+				     specs))
+    (set-record-type-constructor-args! rt
+				       (map (lambda (name)
+					      (get-record-type-field id name))
+					    constructor-args))
+    rt))
+
+; Return the field record for FIELD-ID in record-type TYPE-ID.
+
+(define (get-record-type-field type-id field-id)
+  (let ((rtype (get-record-type type-id)))
+    (cond ((any (lambda (field)
+		  (eq? field-id (record-field-name field)))
+		(record-type-fields rtype))
+	   => identity)
+	  (else
+	   (user-error "~S is not a field of ~S" field-id rtype)))))
+
+; The macro expander for DEFINE-RECORD-TYPE.
+;
+; (define-record-type <id> <type-id>
+;   (<constructor> . <field-names>)
+;   (<field-name> <type> <accessor-name> [<modifier-name>]) ...)
+; 
+; The <type-id> is used only by Pre-Scheme-in-Scheme.
+
+(define (expand-define-record-type exp r c)
+  (let ((id (cadr exp))
+	(maker (cadddr exp))
+	(fields (cddddr exp)))
+    (let ((rt (make-record-type id (cdr maker) fields)))
+      `(,(r 'begin)
+	(,(r 'define) ,maker
+	   (,(r 'let) ((,(r id) (,(r 'make-record) ',id)))
+	     (,(r 'if) (,(r 'not) (,(r 'null-pointer?) ,(r id)))
+	       (,(r 'begin)
+		 . ,(map (lambda (name)
+			   `(,(r 'record-set!) ,(r id) ,name ',id ',name))
+			 (cdr maker))))
+	     ,(r id)))
+	,@(map (lambda (field)
+		 `(,(r 'define) (,(caddr field) ,(r id))
+				(,(r 'record-ref) ,(r id) ',id ',(car field))))
+	       fields)
+	,@(map (lambda (field)
+		 `(,(r 'define) (,(cadddr field) ,(r id) ,(r 'x))
+			(,(r 'record-set!)
+			 ,(r id) ,(r 'x)',id ',(car field))))
+	       (filter (lambda (spec)
+			 (not (null? (cdddr spec))))
+		       fields))))))
+
+; primitives
+;  (make-record 'type . args)
+;  (record-ref thing 'type 'field)
+;  (record-set! thing value 'type 'field)
+;
+; C record creator
+;  global list of these things
+  
+  
\ No newline at end of file
diff --git a/ps-compiler/prescheme/spec.scm b/ps-compiler/prescheme/spec.scm
new file mode 100644
index 0000000..4fa3222
--- /dev/null
+++ b/ps-compiler/prescheme/spec.scm
@@ -0,0 +1,101 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+; Protocol specifications are lists of representations.
+
+(set-compiler-parameter! 'lambda-node-type
+			 (lambda (node)
+			   (let ((vars (lambda-variables node)))
+			     (case (lambda-type node)
+			       ((cont jump)
+				(make-arrow-type (map variable-type vars)
+						 type/unknown)) ; what to do?
+			       ((proc known-proc)
+				(make-arrow-type (map variable-type (cdr vars))
+						 (variable-type (car vars))))
+			       (else
+				(error "unknown type of lambda node ~S" node))))))
+
+(set-compiler-parameter! 'true-value #t)
+(set-compiler-parameter! 'false-value #f)
+
+; Tail-calls with goto-protocols cause the lambda node to be annotated
+; as tail-called.
+; Calls with a tuple argument need their argument spread out into separate
+; variables.
+
+(define (determine-lambda-protocol lambda-node call-refs)
+  (set-lambda-protocol! lambda-node #f)
+  (for-each (lambda (r)
+	      (let ((call (node-parent r)))
+		(cond ((goto-protocol? (literal-value (call-arg call 2)))
+		       (if (not (calls-this-primop? call 'unknown-tail-call))
+			   (bug "GOTO marker in non-tail-all ~S" call))
+		       (set-lambda-protocol! lambda-node 'tail-called)))
+		(unknown-call->known-call call)))
+	    call-refs)
+  (set-calls-known?! lambda-node))
+
+(set-compiler-parameter! 'determine-lambda-protocol determine-lambda-protocol)
+
+(define (unknown-call->known-call call)
+  (remove-call-arg call 2)  ; remove the protocol
+  (set-call-primop! call
+		    (case (primop-id (call-primop call))
+		      ((unknown-call)
+		       (get-primop (enum primop call)))
+		      ((unknown-tail-call)
+		       (get-primop (enum primop tail-call)))
+		      (else
+		       (bug "odd primop in call ~S" call)))))
+
+; CONT is the continuation passed to PROCS.
+
+(define (determine-continuation-protocol cont procs)
+  (for-each (lambda (proc)
+	      (let ((cont-var (car (lambda-variables proc))))
+		(walk-refs-safely
+		 (lambda (ref)
+		   (let ((call (node-parent ref)))
+		     (unknown-return->known-return call cont-var cont)))
+		 cont-var)))
+	    procs))
+
+(set-compiler-parameter! 'determine-continuation-protocol
+			 determine-continuation-protocol)
+
+; If the return is actually a tail-recursive call we change it to
+; a non-tail-recursive one (since we have identified the continuation)
+; and insert the appropriate continuation.
+
+(define (unknown-return->known-return call cont-var cont)
+  (case (primop-id (call-primop call))
+    ((unknown-return)
+     (set-call-primop! call (get-primop (enum primop return))))
+    ((unknown-tail-call tail-call)
+     (let* ((vars (map copy-variable (lambda-variables cont)))
+	    (args (map make-reference-node vars)))
+       (let-nodes ((cont vars (return 0 (* cont-var) . args)))
+	 (replace (call-arg call 0) cont)
+	 (set-call-primop! call
+			   (if (calls-this-primop? call 'tail-call)
+			       (get-primop (enum primop call))
+			       (get-primop (enum primop unknown-call))))
+	 (set-call-exits! call 1)
+	 (if (and (calls-this-primop? call 'unknown-call)
+		  (goto-protocol? (literal-value (call-arg call 2))))
+	     (set-literal-value! (call-arg call 2) #f)))))
+    (else
+     (bug "odd return primop ~S" (call-primop call)))))
+
+(define normal-protocol #f)
+(define goto-protocol 'goto)
+
+(define (goto-protocol? x)
+  (eq? x goto-protocol))
+
+(set-compiler-parameter! 'lookup-primop get-prescheme-primop)
+
+(set-compiler-parameter! 'type/unknown type/unknown)
+
+(set-compiler-parameter! 'type-eq? type-eq?)
+
diff --git a/ps-compiler/prescheme/substitute.scm b/ps-compiler/prescheme/substitute.scm
new file mode 100644
index 0000000..54a57ae
--- /dev/null
+++ b/ps-compiler/prescheme/substitute.scm
@@ -0,0 +1,324 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+; Substituting new variables for old in expressions.
+
+(define *free-exp-vars* #f)
+
+(define (substitute-in-expression exp)
+  (set! *free-exp-vars* '())
+  (set! *letrec-datas* '())
+  (let* ((exp (substitute-in-exp exp))
+	 (free *free-exp-vars*))
+    (set! *free-exp-vars* '())
+    (for-each (lambda (var)
+		(set-variable-flag! var #f))
+	      free)
+    (values exp free)))
+
+(define global-marker (list 'global))
+
+(define (note-binding-use! binding)
+  (let ((var (binding-place binding)))
+    (if (variable? var)
+	(note-variable-use! var))))
+
+(define (note-variable-use! var)
+  (cond ((not (eq? (variable-flag var) global-marker))
+	 (set! *free-exp-vars* (cons var *free-exp-vars*))
+	 (set-variable-flag! var global-marker))))
+
+; Main dispatch
+
+(define (substitute-in-exp node)
+  ((operator-table-ref substitutions (node-operator-id node))
+   node))
+
+; Particular operators
+
+(define substitutions
+  (make-operator-table
+   (lambda (node)
+     (error "no substitution for node ~S" node))))
+
+(define (default-substitution node)
+  (make-similar-node node
+		     (cons (car (node-form node))
+			   (map substitute-in-exp (cdr (node-form node))))))
+
+(define (define-substitution name proc)
+  (operator-define! substitutions name #f proc))
+
+(define-substitution 'literal identity)
+(define-substitution 'quote identity)
+(define-substitution 'unspecific identity)
+
+(define-substitution 'real-external
+  (lambda (node)
+    (let* ((exp (node-form node))
+	   (type (expand-type-spec (cadr (node-form (caddr exp))))))
+      (make-literal-node (make-external-value (node-form (cadr exp))
+					      type)))))
+
+(define op/literal (get-operator 'literal))
+
+(define (make-literal-node x)
+  (make-node op/literal x))
+
+; We copy the names because the same node may occur in multiple places
+; in the tree.
+
+(define-substitution 'lambda
+  (lambda (node)
+    (let* ((new-names (copy-names (cadr (node-form node))))
+	   (body (substitute-in-exp (caddr (node-form node)))))
+      (make-similar-node node
+			 (list (car (node-form node))
+			       new-names
+                               body)))))
+
+(define (copy-names names)
+  (map (lambda (name)
+	 (let ((new (make-similar-node name (node-form name))))
+	   (node-set! name 'substitute new)
+	   new))
+       names))
+
+(define-substitution 'name
+  (lambda (node)
+    (substitute-name-node node #f)))
+
+(define (substitute-name-node node call?)
+  (let ((node (name-node-substitute node)))
+    (let ((binding (node-ref node 'binding)))
+      (cond ((not binding)
+	     (note-name-use! node)
+	     node)
+	    ((primitive? (binding-static binding))
+	     (make-primitive-node (binding-static binding) call?))
+	    ((location? (binding-place binding))
+	     (let ((value (contents (binding-place binding))))
+	       (if (constant? value)
+		   (make-literal-node value)
+		   (identity
+		   (bug "name ~S has non-constant location ~S" node value)))))
+	    (else
+	     (note-binding-use! binding)
+	     node)))))
+
+(define (name-node-substitute node)
+  (let loop ((node node) (first? #t))
+    (cond ((node-ref node 'substitute)
+	   => (lambda (node)
+		(loop node #f)))
+	  ((and first? (not (node-ref node 'binding)))
+	   (user-error "unbound variable ~S" (node-form node)))
+	  (else
+	   node))))
+
+(define-substitution 'set!
+  (lambda (node)
+    (let* ((exp (node-form node))
+	   (name (substitute-name-node (cadr exp) #f))
+	   (binding (node-ref name 'binding)))
+      (if (not (binding? binding))
+	  (user-error "SET! on local variable ~S" (node-form (cadr exp))))
+      ((structure-ref forms note-variable-set!!)
+        (binding-place binding))
+      (note-binding-use! binding)
+      (make-similar-node node
+			 (list (car exp)
+                               name
+                               (substitute-in-exp (caddr exp)))))))
+
+(define-substitution 'call
+  (lambda (node)
+    (let ((proc (car (node-form node)))
+	  (args (cdr (node-form node))))
+      (make-similar-node node
+			 (cons (if (name-node? proc)
+				   (substitute-name-node proc #t)
+				   (substitute-in-exp proc))
+			       (map substitute-in-exp args))))))
+
+; Flush GOTO when it is used with a primitive.
+
+(define-substitution 'goto
+  (lambda (node)
+    (let ((proc (cadr (node-form node)))
+	  (args (cddr (node-form node))))
+      (if (and (name-node? proc)
+	       (bound-to-primitive? proc))
+	  (make-node (get-operator 'call)
+		     (cons (substitute-name-node proc #t)
+			   (map substitute-in-exp args)))
+	  (make-similar-node node
+			     (cons 'goto
+				   (cons (if (name-node? proc)
+					     (substitute-name-node proc #t)
+					     (substitute-in-exp proc))
+					 (map substitute-in-exp args))))))))
+
+(define name-node? (node-predicate 'name))
+
+(define (bound-to-primitive? node)
+  (let ((node (name-node-substitute node)))
+    (let ((binding (node-ref node 'binding)))
+      (and binding
+	   (primitive? (binding-static binding))))))
+
+(define-substitution 'begin default-substitution)
+(define-substitution 'if    default-substitution)
+
+; drop the loophole part
+
+(define-substitution 'loophole
+  (lambda (node)
+    (substitute-in-exp (caddr (node-form node)))))
+
+;----------------------------------------------------------------
+; Breaking LETREC's down to improve type inference and make compilation
+; easier.
+
+(define-substitution 'letrec
+  (lambda (node)
+    (let* ((exp (node-form node))
+	   (vars (map car (cadr exp)))
+	   (vals (map cadr (cadr exp))))
+      (receive (names datas)
+	  (copy-letrec-names vars vals exp)
+	(for-each (lambda (data value)
+		    (expand-letrec-value data value datas exp))
+		  datas
+		  vals)
+	(let ((sets (strongly-connected-components datas
+						   letrec-data-uses
+						   letrec-data-seen?
+						   set-letrec-data-seen?!)))
+	  ;; so we don't keep track of which vars are referenced in the body
+	  (for-each (lambda (d)
+		      (set-letrec-data-seen?! d #t))
+		    datas)
+	  (do ((sets sets (cdr sets))
+	       (exp (substitute-in-exp (caddr exp))
+		    (build-letrec (car sets) exp)))
+	      ((null? sets)
+	       (for-each (lambda (n)
+			   (node-set! n 'letrec-data #f))
+			 names)
+	       exp)))))))
+
+(define-record-type letrec-data
+  (name      ; the name node for which this data exists
+   marker    ; a unique marker for this LETREC
+   cell?     ; variable is SET! or its value is not a (lambda ...).  This is
+             ; always #F until I can think of a reason to allow otherwise.
+   )
+  (value     ; the expanded value of this variable
+   uses      ; a list of variables that VALUE uses
+   seen?     ; #T if this has been seen before during the current expansion
+   ))
+
+(define (copy-letrec-names names vals marker)
+  (let ((names (map (lambda (name value)
+		      (let ((new (make-similar-node name (node-form name)))
+			    (cell? #f)) ; we no longer allow SET! on LETREC vars.
+			(node-set! new 'letrec-data
+				   (letrec-data-maker new marker cell?))
+			(node-set! name 'substitute new)
+			new))
+		    names
+		    vals)))
+    (values names (map (lambda (name) (node-ref name 'letrec-data)) names))))
+
+(define lambda-node? (node-predicate 'lambda))
+
+; List of LETREC bound variables currently in scope.
+
+(define *letrec-datas* '())
+
+(define (note-name-use! name)
+  (let ((data (node-ref name 'letrec-data)))
+    (cond ((and data (not (letrec-data-seen? data)))
+	   (set-letrec-data-seen?! data #t)
+	   (set! *letrec-datas* (cons data *letrec-datas*))))))
+
+; Expand VALUE and determine which of DATAS it uses.
+
+(define (expand-letrec-value data value datas mark)
+  (let ((old-letrec-vars *letrec-datas*))
+    (set! *letrec-datas* '())
+    (for-each (lambda (d) (set-letrec-data-seen?! d #f)) datas)
+    (set-letrec-data-value! data (substitute-in-exp value))
+    (receive (ours others)
+	(partition-list (lambda (data)
+			  (eq? (letrec-data-marker data) mark))
+			*letrec-datas*)
+      (set! *letrec-datas* (append others old-letrec-vars))
+      (set-letrec-data-uses! data ours))))
+
+; If there is only one variable and its value doesn't reference it, then
+; use a LET instead of a LETREC.  Variables whose value is either set! or
+; not a lambda have explicit cells introduced.
+
+(define (build-letrec datas body)
+  (if (and (null? (cdr datas))
+	   (not (memq? (car datas)
+		       (letrec-data-uses (car datas)))))
+      (make-let-node (map letrec-data-name datas)
+		     (map letrec-data-value datas)
+		     body)
+      (receive (cells normal)
+	  (partition-list letrec-data-cell? datas)
+	(make-let-node (map letrec-data-name cells)
+		       (map (lambda (ignore) (unspecific-node))
+			    cells)
+		       (make-letrec-node (map letrec-data-name normal)
+					 (map letrec-data-value normal)
+					 (make-begin-node
+					  (append (map letrec-data->set! cells)
+						  (list body))))))))
+
+(define op/unspecific (get-operator 'unspecific))
+(define op/set! (get-operator 'set!))
+
+(define (unspecific-node)
+  (make-node op/unspecific '()))
+
+(define (letrec-data->set! data)
+  (make-node op/set!
+	     (list 'set!
+		   (letrec-data-name data)
+		   (letrec-data-value data))))
+
+(define (make-let-node names values body)
+  (if (null? names)
+      body
+      (make-node op/call
+		 (cons (make-node op/lambda
+				  (list 'lambda names body))
+		       values))))
+
+(define (make-letrec-node names values body)
+  (if (null? names)
+      body
+      (make-node op/letrec
+		 (list 'letrec
+		       (map list names values)
+		       body))))
+
+(define (make-begin-node nodes)
+  (if (null? (cdr nodes))
+      (car nodes)
+      (make-node op/begin (cons 'begin nodes))))
+
+(define op/call   (get-operator 'call))
+(define op/lambda (get-operator 'lambda))
+(define op/letrec (get-operator 'letrec))
+(define op/begin  (get-operator 'begin))
+
+;----------------------------------------------------------------
+; A version of MAKE-SIMILAR-NODE that actually makes a new node.
+; I wish this could keep the old node's list of properties.
+
+(define (make-similar-node node form)
+  (make-node (node-operator node) form))
diff --git a/ps-compiler/prescheme/test/boolean.scm b/ps-compiler/prescheme/test/boolean.scm
new file mode 100644
index 0000000..7fcc255
--- /dev/null
+++ b/ps-compiler/prescheme/test/boolean.scm
@@ -0,0 +1,25 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+
+
+(define (test in out)
+  (write-string '"Type in two numbers: " out)
+  (let* ((i (read-integer in))
+         (j (read-integer in)))
+    (write-string '"A = " out)
+    (write-integer i out)
+    (newline out)
+    (write-string '"B = " out)
+    (write-integer j out)
+    (newline out)
+    (write-string (if (and (< i j)
+			   (or (= (remainder i '2) '0)
+			       (= (remainder j '2) '0)))
+		      '"A < B and A or B is even"
+		      '"A >= B or A and B are both odd")
+		  out)
+    (newline out)
+    '0))
+
+(test (current-input-port) (current-output-port))
diff --git a/ps-compiler/prescheme/test/buffer.scm b/ps-compiler/prescheme/test/buffer.scm
new file mode 100644
index 0000000..3d7cf68
--- /dev/null
+++ b/ps-compiler/prescheme/test/buffer.scm
@@ -0,0 +1,72 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+; (port->stream port type) -> stream or error value
+; (
+;
+;
+;
+
+
+(define-record-type stream
+  make-stream
+  (port   port)
+  (type   int8u)
+  (buffer int32)   ; pointer the start of the buffer
+  (size   int32)
+  (loc    int32)   ; pointer to the next char to be read or the next slot to
+                   ; be written
+  (limit  int32))  ; end of the available characters
+
+(define buffer-size 1024)
+
+(define (port->stream port type)
+  (let ((buffer (allocate-memory buffer-size))
+	(stream (make-stream)))
+    (if (or (null-memory? buffer)
+	    (null-pointer? stream))
+	(error "out of memory"))
+    (set-stream-port!   stream port)
+    (set-stream-type!   stream type)
+    (set-stream-buffer! stream buffer)
+    (set-stream-size!   stream buffer-size)
+    (set-stream-loc!    stream buffer)
+    (set-stream-limit!  stream buffer)
+    buffer))
+
+(define (stream-read-char stream)
+  (let ((loc (stream-loc stream)))
+    (cond ((< loc (stream-limit stream))
+	   (let ((ch (unsigned-byte-ref loc)))
+	     (set-stream-loc! stream (+ 1 (stream-loc stream)))
+	     ch))
+	  (else
+	   (let* ((buffer (stream-buffer stream))
+		  (count (read-block (stream-port stream)
+				     buffer
+				     (stream-size stream))))
+	     (cond ((= count 0)   ; EOF
+		    0)
+		   (else
+		    (set-stream-loc! stream (+ buffer 1))
+		    (set-stream-limit! stream (+ buffer count))
+		    (unsigned-byte-ref buffer))))))))
+
+; this will need to be PCLUSR'd.
+
+(define (stream-write-char stream char)
+  (let ((loc (stream-loc stream)))
+    (cond ((< loc (stream-limit stream))
+	   (unsigned-byte-set! loc char)
+	   (set-stream-loc! stream (+ 1 (stream-loc stream))))
+	  (else
+	   (let* ((buffer (stream-buffer stream))
+		  (count (write-block (stream-port stream)
+				      buffer
+				      (stream-limit stream))))
+	     (cond ((= count 0)   ; EOF
+		    0)
+		   (else
+		    (set-stream-loc! stream (+ buffer 1))
+		    (set-stream-limit! stream (+ buffer count))
+		    (unsigned-byte-ref buffer))))))))
diff --git a/ps-compiler/prescheme/test/bvector.scm b/ps-compiler/prescheme/test/bvector.scm
new file mode 100644
index 0000000..6fa8f56
--- /dev/null
+++ b/ps-compiler/prescheme/test/bvector.scm
@@ -0,0 +1,11 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define (test)
+  (let ((v (make-byte-vector 10))
+	(out (current-output-port)))
+    (write-number (byte-vector-ref v 4) out)
+    (byte-vector-set! v 5 100)
+    (write-number (byte-vector-ref v 5) out)
+    (write-number (byte-vector-word-ref v 4) out)))
+
diff --git a/ps-compiler/prescheme/test/cell.scm b/ps-compiler/prescheme/test/cell.scm
new file mode 100644
index 0000000..958f64a
--- /dev/null
+++ b/ps-compiler/prescheme/test/cell.scm
@@ -0,0 +1,18 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define *count* 0)
+
+(define (increment)
+  (set! *count* (+ *count* 1)))
+
+(define (value)
+  *count*)
+
+(define (test out)
+  (increment)
+  (increment)
+  (write-number (value) out)
+  (newline out))
+
+(test (current-output-port))
diff --git a/ps-compiler/prescheme/test/coerce.scm b/ps-compiler/prescheme/test/coerce.scm
new file mode 100644
index 0000000..e86fe86
--- /dev/null
+++ b/ps-compiler/prescheme/test/coerce.scm
@@ -0,0 +1,29 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+
+(define-local-syntax (define-primitive id nargs)
+  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
+    `(define (,id . ,args)
+       (call-primitively ,id . ,args))))
+
+(define-primitive make-byte-vector 1)
+(define-primitive null-pointer? 1)
+
+(define (byte-vector-ref vec index)
+  (call-primitively byte-contents-int8 (pointer-add vec index)))
+
+(define (byte-vector-set! vec index value)
+  (call-primitively byte-set-contents-int8! (pointer-add vec index) value))
+
+(define (pointer->integer x)
+  (call-primitively coerce x '(pointer int8) 'int32))
+
+(define (integer->pointer x)
+  (call-primitively coerce x 'int32 '(pointer int8)))
+
+(define (test)
+  (let ((bv (make-byte-vector 10)))
+    (if (null-pointer? bv)
+	100
+	(pointer->integer bv))))
\ No newline at end of file
diff --git a/ps-compiler/prescheme/test/dispatch.scm b/ps-compiler/prescheme/test/dispatch.scm
new file mode 100644
index 0000000..65816e2
--- /dev/null
+++ b/ps-compiler/prescheme/test/dispatch.scm
@@ -0,0 +1,64 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define (fact n)
+  (let loop ((i n) (r 1))
+    (if (<= i 1)
+	r
+	(loop (- i 1) (* i r)))))
+
+(define (default y) y)
+
+(define do-it (make-vector 5))
+
+(do ((i 0 (+ i 1)))
+    ((>= i 5))
+  (vector-set! do-it i default))
+
+(define (add-entry i k)
+  (let ((f (fact k)))
+    (vector-set! do-it i (lambda (x) (+ x f)))))
+
+(add-entry 0 1)
+;(add-entry 1 1)
+(add-entry 2 3)
+(add-entry 3 4)
+(add-entry 4 4)
+   
+(define (test x)
+  ((vector-ref do-it x) 5))
+
+(define (main)
+  (write-number (test (read-number (current-input-port)))
+		(current-output-port)))
+
+(define (digit? ch)
+  (let ((ch (char->ascii ch)))
+    (and (>= ch (char->ascii #\0))
+	 (<= ch (char->ascii #\9)))))
+
+(define (read-number port)
+  (let loop ((r 0))
+    (ps-read-char port
+      (lambda (ch)
+	(cond ((digit? ch)
+	       (loop (+ (- (char->ascii ch) (char->ascii #\0))
+			(* r 10))))
+	      (else r)))
+      (lambda () 0))))
+
+(define (write-number x port)
+  (really-write-number (cond ((< x 0)
+			      (write-char #\- port)
+			      (- 0 x))
+			     (else
+			      x))
+		       port)
+  (newline port))
+
+(define (really-write-number x port)
+    (if (>= x 10)
+	(really-write-number (quotient x 10) port))
+    (write-char (ascii->char (+ (remainder x 10)
+				(char->ascii #\0)))
+		port))
diff --git a/ps-compiler/prescheme/test/dispatch2.scm b/ps-compiler/prescheme/test/dispatch2.scm
new file mode 100644
index 0000000..d467fa5
--- /dev/null
+++ b/ps-compiler/prescheme/test/dispatch2.scm
@@ -0,0 +1,57 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define-local-syntax (define-primitive id nargs)
+  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
+    `(define (,id . ,args)
+       (call-primitively ,id . ,args))))
+
+(define-primitive + 2)
+(define-primitive - 2)
+(define-primitive * 2)
+(define-primitive < 2)
+
+(define-primitive make-vector 2)
+(define-primitive pointer-add 2)
+(define-primitive contents 1)
+(define-primitive set-contents! 2)
+
+(define *current-input-port*
+  (call-primitively stdin))
+
+(define *current-output-port*
+  (call-primitively stdout))
+
+(define (current-input-port)
+  *current-input-port*)
+
+(define (current-output-port)
+  *current-output-port*)
+
+(define (vector-ref vec index)
+  (contents (pointer-add vec index)))
+
+(define (vector-set! vec index value)
+  (set-contents! (pointer-add vec index) value))
+
+(define (default y) y)
+
+(define do-it (make-vector 5 default))
+
+(define (add-entry i k)
+  (vector-set! do-it i (lambda (x) (+ x k))))
+
+(add-entry 0 1)
+;(add-entry 1 1)
+(add-entry 2 3)
+(add-entry 3 4)
+(add-entry 4 4)
+   
+(define (test x)
+  ((vector-ref do-it x) 5))
+
+(define (main)
+  (write-number (test (read-number (current-input-port)))
+		(current-output-port)))
+
+
diff --git a/ps-compiler/prescheme/test/eval.scm b/ps-compiler/prescheme/test/eval.scm
new file mode 100644
index 0000000..363c174
--- /dev/null
+++ b/ps-compiler/prescheme/test/eval.scm
@@ -0,0 +1,18 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+
+(define (fact n)
+  (let loop ((i n) (r 1))
+    (if (<= i 1)
+	r
+	(loop (- i 1) (* i r)))))
+
+(define facts (make-vector 5))
+
+(do ((i 0 (+ i 1)))
+    ((< 4 i))
+  (vector-set! facts i (fact i)))
+
+(define f4 (vector-ref facts 4))
+
diff --git a/ps-compiler/prescheme/test/eval2.scm b/ps-compiler/prescheme/test/eval2.scm
new file mode 100644
index 0000000..bc10d6b
--- /dev/null
+++ b/ps-compiler/prescheme/test/eval2.scm
@@ -0,0 +1,12 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define-local-syntax (define-primitive id nargs)
+  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
+    `(define (,id . ,args)
+       (call-primitively ,id . ,args))))
+
+(define-primitive ashr 2)
+
+(define high-bits ashr)
+
diff --git a/ps-compiler/prescheme/test/eval3.scm b/ps-compiler/prescheme/test/eval3.scm
new file mode 100644
index 0000000..9b73616
--- /dev/null
+++ b/ps-compiler/prescheme/test/eval3.scm
@@ -0,0 +1,38 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define-local-syntax (define-primitive id nargs)
+  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
+    `(define (,id . ,args)
+       (call-primitively ,id . ,args))))
+
+(define-primitive ashl 2)
+(define-primitive ashr 2)
+(define-primitive = 2)
+(define-primitive bitwise-and 2)
+
+(define (input-type pred coercer)  ;Alonzo wins
+  (lambda (f) (f pred coercer)))
+
+(define (input-type-predicate type) (type (lambda (x y) y x)))
+(define (input-type-coercion type)  (type (lambda (x y) x y)))
+
+(define (no-coercion x) x)
+
+(define (odd? x)
+  (= 1 (bitwise-and x 1)))
+
+(define (extract-odd x)
+  (ashr x 1))
+
+(define any->      (input-type (lambda (x) x #t) no-coercion))
+(define odd->      (input-type odd?  extract-odd))
+
+(define (test x y)
+  (if (and ((input-type-predicate any->) x)
+	   ((input-type-predicate odd->) y))
+      (let ((a ((input-type-coercion any->) x))
+	    (b ((input-type-coercion odd->) y)))
+	(+ a b))
+      x))
+
diff --git a/ps-compiler/prescheme/test/external.scm b/ps-compiler/prescheme/test/external.scm
new file mode 100644
index 0000000..3fc7874
--- /dev/null
+++ b/ps-compiler/prescheme/test/external.scm
@@ -0,0 +1,10 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define foo
+  (external (=> (int32 int32) unit)
+	    (lambda (x y)
+	      (display (+ x y)))))
+
+(define (test)
+  (foo 3 4))
diff --git a/ps-compiler/prescheme/test/fact.cps b/ps-compiler/prescheme/test/fact.cps
new file mode 100644
index 0000000..cc494ad
--- /dev/null
+++ b/ps-compiler/prescheme/test/fact.cps
@@ -0,0 +1,27 @@
+(FORM 0 random okay #f
+  ()
+
+    (P #f_0 (c_1)
+      (LET* (((loop_2)   (allocate 'single-set 'ptr))
+             (()         (set-contents loop_2 'cell '0 '0 ^loop_3)))
+        (jump 0 (contents loop_2 'cell '0 '0) '5 '1)))
+
+     (J loop_3 (i_4 r_5)
+       (LET* (((c_6)*     ^c_7))
+         (test 2 ^g_8 ^g_9 (less? '1 i_4))))
+
+      (C g_8 ()
+        (return 0 c_6 '#f))
+
+      (C g_9 ()
+        (return 0 c_6 '#t))
+
+      (C c_7 (v_10)
+        (test 2 ^g_11 ^g_12 v_10))
+
+       (C g_11 ()
+         (unknown-return 0 c_1 '1 r_5))
+
+       (C g_12 ()
+         (jump 0 (contents loop_2 'cell '0 '0) (subtract i_4 '1) (multiply i_4 r_5))))
+
diff --git a/ps-compiler/prescheme/test/fact.scm b/ps-compiler/prescheme/test/fact.scm
new file mode 100644
index 0000000..6119aa2
--- /dev/null
+++ b/ps-compiler/prescheme/test/fact.scm
@@ -0,0 +1,14 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+
+(define *one* 1)
+
+(define (fact n)
+  (let loop ((i n) (r *one*))
+    (if (<= *one* i)
+	(loop (- i *one*) (* i r))
+	r)))
+
+(define (all)
+  (set! *one* (fact (if (> (fact 10) 100) 10 20))))
diff --git a/ps-compiler/prescheme/test/fact2.scm b/ps-compiler/prescheme/test/fact2.scm
new file mode 100644
index 0000000..7186372
--- /dev/null
+++ b/ps-compiler/prescheme/test/fact2.scm
@@ -0,0 +1,85 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+
+(define (foo)
+  (fact 10)
+  (fact 20))
+
+(foo)
+(foo)
+(fact 5)
+
+(define *one* (unassigned))
+
+(define-local-syntax (define-primitive id nargs)
+  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
+    `(define (,id . ,args)
+       (call-primitively ,id . ,args))))
+
+(define-local-syntax (define-effect-primitive id nargs)
+  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
+    `(define (,id . ,args)
+       (call-primitively ,id . ,args)
+       (call-primitively undefined-value))))
+
+(define-primitive + 2)
+(define-primitive - 2)
+(define-primitive * 2)
+(define-primitive < 2)
+
+;(define-primitive quotient  2)
+;(define-primitive remainder 2)
+
+(define-primitive char->ascii 1)
+(define-primitive ascii->char 1)
+
+(define-effect-primitive write-char   2) 
+
+(define (unassigned) (call-primitively undefined-value))
+
+(define (byte-vector-ref vec index)
+  (call-primitively byte-contents (ptr+ vec index)))
+
+(define (byte-vector-set! vec index value)
+  (call-primitively byte-set-contents! (ptr+ vec index) value))
+
+(define (vector-set! vec index value)
+  (call-primitively set-contents! (ptr+ vec (* index 4)) value))
+
+;(write-number-no-newline 102 port)
+
+;(define (write-number-no-newline x port)
+;  (let ((x (cond ((< x 0)
+;                  (write-char '#\- port)
+;                  (- 0 x))
+;                 (else
+;                  x))))
+;    (let loop ((x x) (mask foo))
+;      (let ((digit (quotient x mask)))
+;        (write-char (ascii->char (+ digit (char->ascii '#\0))) port)
+;        (if (< mask 1)
+;	    (loop (remainder x mask) (quotient mask 10)))))))
+
+(define (fact n)
+  (let loop ((i n) (r *one*))
+    (if (<= *one* i)
+	(loop (- i *one*) (* i r))
+	r)))
+
+;(define (poobah x)
+;  (+ x (* x (+ x (* x *two*)))))
+
+;(define *two* 2)
+
+(define (<= x y)
+  (not (< y x)))
+
+(define (not x)
+  (if x #f #t))
+
+(define (identity x)
+  x)
+
+(define (two x)
+  2)
\ No newline at end of file
diff --git a/ps-compiler/prescheme/test/goto.scm b/ps-compiler/prescheme/test/goto.scm
new file mode 100644
index 0000000..3c26d12
--- /dev/null
+++ b/ps-compiler/prescheme/test/goto.scm
@@ -0,0 +1,20 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+
+(define (odd? x)
+  (cond ((= x 0)
+	 #f)
+;	((= x 100)
+;	 (foo))
+	(else
+	 (goto even? (- x 1)))))
+
+(define (even? x)
+  (if (= x 0)
+      #t
+      (goto odd? (- x 1))))
+
+(define (test x)
+  (if (odd? (+ x 1))
+      (error "an even number" x)))
diff --git a/ps-compiler/prescheme/test/hoist.scm b/ps-compiler/prescheme/test/hoist.scm
new file mode 100644
index 0000000..9c715b2
--- /dev/null
+++ b/ps-compiler/prescheme/test/hoist.scm
@@ -0,0 +1,15 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+
+(define (foo x y)
+  (let ((bar (lambda (y)
+	       (let ((baz (lambda (a b)
+			    (foo (- a 2) (+ 3 b)))))
+		 (+ (baz y 1) (baz (+ y 1) 2))))))
+    (if (= x 0)
+	(goto bar 10)
+	(goto bar 4))))
+
+(define (test)
+  (foo 30 40))
\ No newline at end of file
diff --git a/ps-compiler/prescheme/test/integers.scm b/ps-compiler/prescheme/test/integers.scm
new file mode 100644
index 0000000..f8aedbb
--- /dev/null
+++ b/ps-compiler/prescheme/test/integers.scm
@@ -0,0 +1,11 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+
+(define (main)
+  (write-number (+ (read-number (current-input-port)) 100)
+		(current-output-port))
+  0)
+
+
+
diff --git a/ps-compiler/prescheme/test/letrec.scm b/ps-compiler/prescheme/test/letrec.scm
new file mode 100644
index 0000000..53ee536
--- /dev/null
+++ b/ps-compiler/prescheme/test/letrec.scm
@@ -0,0 +1,44 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define (t1)
+  (let loop ((x 1))
+    (if (g x)
+	(loop (h x))
+	x)))
+
+(define (t2)
+  (let loop ((x 1))
+    (if (g x) x y)))
+
+(define (t3)
+  (letrec ((loop (lambda (x)
+		   (if #t x (loop x)))))
+    (loop 4)))
+
+(define (t4)
+  (letrec ((loop (lambda (x)
+		   (if #t x (loop x))))
+	   (loop2 (lambda (x)
+		    (if x x (loop2 x)))))
+    (loop 4)))
+
+(define (t5)
+  (letrec ((loop (lambda (x)
+		   (if #t x (loop x))))
+	   (loop2 (lambda (x)
+		    (if x x (loop2 x)))))
+    (g (loop 4) (loop2 5))))
+
+(define (t6 y)
+  (letrec ((loop (if y
+		     (lambda (x) 5)
+		     (lambda (x) 6))))
+    (loop 4)))
+
+(define (t7 y)
+  (letrec ((loop (if y
+		     (lambda (x) 5)
+		     (lambda (x) (loop 6)))))
+    (loop 4)))
+
diff --git a/ps-compiler/prescheme/test/list.scm b/ps-compiler/prescheme/test/list.scm
new file mode 100644
index 0000000..43dada2
--- /dev/null
+++ b/ps-compiler/prescheme/test/list.scm
@@ -0,0 +1,236 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+; write s-expressions
+
+; Memory
+
+(define *memory*)
+(define *hp*)
+
+(define (initialize-memory! size)
+  (set! *memory* (allocate-memory size))
+  ;(if (null-pointer? *memory*)
+  ;    (error "out of memory, unable to continue"))
+  (set! *hp* *memory*))
+
+(define (allocate size)
+  (let ((p *hp*))
+    (set! *hp* (address+ *hp* size))
+    p))
+
+(define (words->a-units x)
+  (* x 4))
+
+; Data
+
+(define tag-bits 1)
+(define tag-mask (- (shift-left 1 tag-bits) 1))
+
+(define tag/fixnum 0)
+(define tag/pair   1)
+
+(define (enter-fixnum x)
+  (+ (shift-left x tag-bits) tag/fixnum))
+
+(define (extract-fixnum x)
+  (arithmetic-shift-right x tag-bits))
+
+(define (make-predicate tag)
+  (lambda (x)
+    (= tag (bitwise-and x tag-mask))))
+
+(define fixnum?  (make-predicate tag/fixnum))
+(define my-pair? (make-predicate tag/pair))
+
+(define (make-accessor tag offset)
+  (lambda (x)
+    (word-ref (address+ (integer->address (+ x (- 0 tag)))
+			(words->a-units offset)))))
+
+(define (make-setter tag offset)
+  (lambda (x v)
+    (word-set! (address+ (integer->address (+ x (- 0 tag)))
+			 (words->a-units offset))
+	       v)))
+
+(define pair-size 16)   ; bytes
+
+(define head (make-accessor tag/pair 0))
+(define tail (make-accessor tag/pair 1))
+
+(define set-head! (make-setter tag/pair 0))
+(define set-tail! (make-setter tag/pair 1))
+
+(define (make-pair x y)
+  (let ((p (+ tag/pair (address->integer (allocate pair-size)))))
+    (set-head! p x)
+    (set-tail! p y)
+    p))
+
+(define null tag/pair)
+
+(define (my-null? x)
+  (= x null))
+
+(define (print-s-exp x out)
+  (cond ((fixnum? x)
+         (write-number-no-newline (extract-fixnum x) out))
+        ((my-null? x)
+         (write-char #\( out)
+         (write-char #\) out))
+        ((my-pair? x)
+         (write-char #\( out)
+         (print-s-exp (head x) out)
+         (let loop ((x (tail x)))
+           (cond ((my-null? x)
+                  (write-char #\) out))
+                 ((my-pair? x)
+                  (write-char #\space out)
+                  (print-s-exp (head x) out)
+                  (loop (tail x)))
+                 (else
+                  (write-char #\space out)
+                  (write-char #\. out)
+                  (write-char #\space out)
+                  (print-s-exp x out)
+                  (write-char #\) out)))))))
+
+(define *input-port*)
+(define *peeked-char?* #f)
+(define *peeked-char*)
+
+(define (readc)
+  (cond (*peeked-char?*
+	 (set! *peeked-char?* #f)
+	 *peeked-char*)
+	(else
+	 (call-with-values
+	  (lambda ()
+	    (read-char *input-port*))
+	  (lambda (ch eof? status)
+	    (if eof? (ascii->char 0) ch))))))
+
+(define (peekc)
+  (if *peeked-char?*
+      *peeked-char*
+      (call-with-values
+       (lambda ()
+	 (read-char *input-port*))
+       (lambda (ch eof? status)
+	 (if eof?
+	     (ascii->char 0)
+	     (begin
+	       (set! *peeked-char?* #t)
+	       (set! *peeked-char* ch)
+	       ch))))))
+
+(define (digit? ch)
+  (let ((ch (char->ascii ch)))
+    (and (>= ch (char->ascii #\0))
+	 (<= ch (char->ascii #\9)))))
+
+(define (read-number)
+  (let loop ()
+    (case (peekc)
+      ((#\-)
+       (readc)
+       (- 0 (really-read-number)))
+      ((#\+)
+       (readc)
+       (really-read-number))
+      (else
+       (really-read-number)))))
+
+(define (really-read-number)
+  (let loop ((r 0))
+    (let ((ch (peekc)))
+      (cond ((digit? ch)
+	     (readc)
+	     (loop (+ (- (char->ascii ch) (char->ascii #\0))
+		      (* r 10))))
+	    (else r)))))
+
+(define (read-s-exp)
+  (case (peekc)
+    ((#\space #\newline)
+     (readc)
+     (read-s-exp))
+    ((#\- #\+)
+     (enter-fixnum (read-number)))
+    ((#\()
+     (readc)
+     (read-list))
+    (else
+     (if (digit? (peekc))
+	 (enter-fixnum (read-number))
+	 -1))))
+
+(define (read-list)
+  (case (peekc)
+    ((#\space #\newline)
+     (readc)
+     (read-list))
+    ((#\))
+     (readc)
+     null)
+    ((#\.)
+     (readc)       ; eat the dot
+     (let ((res (read-s-exp)))
+       (if (read-r-paren)
+	   res
+	   -1)))
+    (else
+     (let ((head (read-s-exp)))
+       (make-pair head (read-list))))))
+
+(define (read-r-paren)
+  (case (peekc)
+    ((#\space #\newline)
+     (readc)
+     (read-r-paren))
+    ((#\))
+     #t)
+    (else #f)))
+
+; Printing integers
+
+; Return 10**n such that 10**n <= x < 10**(n+1)
+
+(define (integer-mask x)
+  (do ((x x (quotient x 10))
+       (mask 1 (* mask 10)))
+      ((< x 10) mask)))
+
+; Write positive integer X out to PORT
+
+(define (write-number x port)
+  (write-number-no-newline x port)
+  (write-char '#\newline port))
+
+(define (write-number-no-newline x port)
+  (let ((x (cond ((< x 0)
+                  (write-char '#\- port)
+                  (- 0 x))
+                 (else
+                  x))))
+    (let loop ((x x) (mask (integer-mask x)))
+      (let ((digit (quotient x mask)))
+        (write-char (ascii->char (+ digit (char->ascii '#\0))) port)
+        (if (> mask 1)
+	    (loop (remainder x mask) (quotient mask 10)))))))
+
+
+(define (test size)
+  (initialize-memory! size)
+  (let ((s-exp (make-pair (enter-fixnum 1)
+                (make-pair (enter-fixnum 2)
+                 (make-pair (make-pair (enter-fixnum 3) (enter-fixnum 4))
+                            null))))
+	(out (current-output-port)))
+    (print-s-exp s-exp out)
+    (newline out)
+    (set! *input-port* (current-input-port))
+    (print-s-exp (read-s-exp) out)
+    (newline out)))
+
diff --git a/ps-compiler/prescheme/test/loop.scm b/ps-compiler/prescheme/test/loop.scm
new file mode 100644
index 0000000..b390d8d
--- /dev/null
+++ b/ps-compiler/prescheme/test/loop.scm
@@ -0,0 +1,54 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+
+(xodd? 10)
+(xodd? 5)
+
+(define-local-syntax (define-primitive id nargs)
+  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
+    `(define (,id . ,args)
+       (call-primitively ,id . ,args))))
+
+(define-primitive + 2)
+(define-primitive - 2)
+(define-primitive * 2)
+(define-primitive < 2)
+(define-primitive = 2)
+
+(define (xodd? x)
+  (cond ((= 0 x)
+	 #f)
+	((< 100 x)                  ; efficiency hack
+	 (goto odd? (- x 100)))
+	((< 1000 x)                  ; efficiency hack
+	 (goto xodd? (- x 100)))
+	(else
+	 (goto xeven? (- x 1)))))
+
+(define (xeven? x)
+  (cond ((= 0 x)
+	 #t)
+	((< 100 x)                  ; efficiency hack
+	 (goto xeven? (- x 100)))
+	(else
+	 (goto xodd? (- x 1)))))
+
+
+(define (odd? x)
+  (cond ((= 0 x)
+	 #f)
+	((< 100 x)                  ; efficiency hack
+	 (goto odd? (- x 100)))
+	(else
+	 (goto even? (- x 1)))))
+
+(define (even? x)
+  (cond ((= 0 x)
+	 #t)
+	((< 100 x)                  ; efficiency hack
+	 (goto even? (- x 100)))
+	(else
+	 (goto odd? (- x 1)))))
+
+
diff --git a/ps-compiler/prescheme/test/memory.scm b/ps-compiler/prescheme/test/memory.scm
new file mode 100644
index 0000000..5a30ba6
--- /dev/null
+++ b/ps-compiler/prescheme/test/memory.scm
@@ -0,0 +1,8 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define (test x i)
+  (let ((m (allocate-memory 10)))
+    (unsigned-byte-set! (+ m i) x)
+    (word-set! (+ m i) (+ 1 (word-ref (+ m i))))
+    (unsigned-byte-ref (+ m i))))
diff --git a/ps-compiler/prescheme/test/package-defs.scm b/ps-compiler/prescheme/test/package-defs.scm
new file mode 100644
index 0000000..311a64e
--- /dev/null
+++ b/ps-compiler/prescheme/test/package-defs.scm
@@ -0,0 +1,67 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define-structures ((fact (export *one* fact all)))
+  (open prescheme)
+  (files fact))
+
+(define-structures ((list (export test)))
+  (open prescheme ps-memory)
+  (files list))
+
+(define-structures ((dispatch (export main)))
+  (open prescheme)
+  (files dispatch))
+
+(define-structures ((vector (export test)))
+  (open prescheme)
+  (files vector))
+
+(define-structures ((string (export test)))
+  (open prescheme)
+  (files string))
+
+(define-structures ((goto (export test odd?)))
+  (open prescheme)
+  (files goto))
+
+(define-structures ((external (export test)))
+  (open prescheme)
+  (files external))
+
+(define-structures ((eval (export f4)))
+  (open prescheme)
+  (files eval))
+
+(define-structures ((memory (export test)))
+  (open prescheme)
+  (files memory))
+
+(define-structures ((poly (export test)))
+  (open prescheme)
+  (files poly))
+
+(define-structures ((select (export test)))
+  (open prescheme)
+  (files select))
+
+(define-structures ((hoist (export test)))
+  (open prescheme)
+  (files hoist))
+
+(define-structures ((record (export init cons member? reverse!)))
+  (open prescheme ps-record-types)
+  (files record))
+
+(define-structures ((buffer (export port->stream stream-read-char)))
+  (open prescheme)
+  (files buffer))
+
+(define-structures ((values (export test)))
+  (open prescheme)
+  (files values))
+
+(define-structures ((write (export test)))
+  (open prescheme)
+  (files write))
+
diff --git a/ps-compiler/prescheme/test/poly.scm b/ps-compiler/prescheme/test/poly.scm
new file mode 100644
index 0000000..8cb2bef
--- /dev/null
+++ b/ps-compiler/prescheme/test/poly.scm
@@ -0,0 +1,11 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define (identity x) x)  ; can't get much more polymorphic than that
+
+(define (test x)
+  (cond (#f
+	 (vector-ref (identity (make-vector 3)) 2))
+	(else
+	 (+ (identity (+ x 3)) (identity (+ x 2))))))
+
diff --git a/ps-compiler/prescheme/test/prescheme.h b/ps-compiler/prescheme/test/prescheme.h
new file mode 100644
index 0000000..df80ac1
--- /dev/null
+++ b/ps-compiler/prescheme/test/prescheme.h
@@ -0,0 +1,70 @@
+#include <errno.h>
+
+#define PS_READ_CHAR(PORT,RESULT,EOFP,STATUS)		\
+{							\
+  FILE * TTport = PORT;					\
+  int TTchar;						\
+  if (EOF == (TTchar = getc(TTport)))			\
+    RESULT = ps_read_char(TTport, &EOFP, &STATUS, 0==1);\
+  else {						\
+    RESULT = TTchar; 					\
+    EOFP = 0;						\
+    STATUS = 0; }					\
+}
+
+#define PS_PEEK_CHAR(PORT,RESULT,EOFP,STATUS)		\
+{							\
+  FILE * TTport = PORT;					\
+  int TTchar;						\
+  if (EOF == (TTchar = getc(TTport)))			\
+    RESULT = ps_read_char(TTport, &EOFP, &STATUS, 0==0);\
+  else {						\
+    RESULT = TTchar; 					\
+    ungetc(RESULT, TTport);				\
+    EOFP = 0;						\
+    STATUS = 0; }					\
+}
+
+#define PS_READ_INTEGER(PORT,RESULT,EOFP,STATUS)	\
+RESULT = ps_read_integer(PORT,&EOFP,&STATUS);
+
+#define PS_WRITE_CHAR(CHAR,PORT,STATUS)			\
+{							\
+  FILE * TTport = PORT;					\
+  char TTchar = CHAR;					\
+  if (EOF == putc(TTchar,TTport))			\
+    STATUS = ps_write_char(TTchar,TTport);		\
+  else {						\
+    STATUS = 0; }					\
+}
+
+extern FILE *ps_open_input_file(unsigned char *, long *);
+extern FILE *ps_open_output_file(unsigned char *, long *);
+extern long ps_close(FILE *);
+extern char ps_read_char(FILE *, unsigned char *, long *, char);
+extern long ps_read_integer(FILE *, unsigned char *, long *);
+extern long ps_write_char(char, FILE *);
+extern long ps_write_integer(long, FILE *);
+extern long ps_write_string(unsigned char *, FILE *);
+extern long ps_read_block(FILE *, char *, long, unsigned char *, long *);
+extern long ps_write_block(FILE *, char *, long);
+extern unsigned char *ps_error_string(long);
+extern void ps_error(unsigned char *, ...);
+
+/* C shifts may not work if the amount is greater than the machine word size */
+/* Patched by JAR 6/6/93 */
+
+#define PS_SHIFT_RIGHT(X,Y,RESULT)   \
+{                                    \
+  long TTx = X,  TTy = Y;            \
+  RESULT = TTy >= 32 ? (TTx < 0 ? -1 : 0) : TTx >> TTy; \
+}  
+
+#define PS_SHIFT_LEFT(X,Y,RESULT)    \
+{                                    \
+  long TTy = Y;                      \
+  RESULT = TTy >= 32 ? 0 : X << TTy; \
+}  
+
+extern long TTreturn_value, TTrun_machine();
+
diff --git a/ps-compiler/prescheme/test/record.scm b/ps-compiler/prescheme/test/record.scm
new file mode 100644
index 0000000..647d48e
--- /dev/null
+++ b/ps-compiler/prescheme/test/record.scm
@@ -0,0 +1,29 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+
+(define-data-type list
+  (pair? (cons car cdr)
+	 (car integer car set-car!)
+	 (cdr list    cdr set-cdr!))
+  (null? null))
+
+(define (member? list x)
+  (let loop ((list list))
+    (cond ((null? list)
+	   #f)
+	  ((= x (car list))
+	   #t)
+	  (else
+	   (loop (cdr list))))))
+
+(define (reverse! list)
+  (if (or (null? list)
+	  (null? (cdr list)))
+      list
+      (let loop ((list list) (prev null))
+	(let ((next (cdr list)))
+	  (set-cdr! list prev)
+	  (if (null? next)
+	      list
+	      (loop next list))))))
diff --git a/ps-compiler/prescheme/test/select.scm b/ps-compiler/prescheme/test/select.scm
new file mode 100644
index 0000000..01e6876
--- /dev/null
+++ b/ps-compiler/prescheme/test/select.scm
@@ -0,0 +1,69 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define (test)
+  (let ((in (current-input-port))
+	(out (current-output-port))
+	(s1 (make-port-set))
+	(s2 (make-port-set)))
+    (let loop ((i 0))
+      (cond ((char-ready? in)
+	     (got-char in out i)
+	     (loop 0))
+	    (else
+	     (clear-port-set! s1)
+	     (clear-port-set! s2)
+	     (add-to-port-set! s1 in)
+	     (case (find-ready-ports s1 s2 #f)
+	       ((0)
+		(loop (+ i 1)))
+	       ((1)
+		(cond ((port-set-member? s1 in)
+		       (got-char in out i)
+		       (loop 0))
+		      (else
+		       (write-string "not in port set" out)
+		       (newline out))))
+	       (else
+		(write-string "funny port count " out))))))))
+
+(define (got-char in out i)
+  (write-string "Got " out)
+  (ps-read-char in
+		(lambda (char)
+		  (write-number-no-newline (ascii->char char) out))
+		(lambda ()
+		  (write-string "EOF!" out)))
+  (write-string " after " out)
+  (write-number i out))
+
+; Printing integers
+
+; Return 10**n such that 10**n <= x < 10**(n+1)
+
+(define (integer-mask x)
+  (do ((x x (quotient x 10))
+       (mask 1 (* mask 10)))
+      ((< x 10) mask)))
+
+; Write positive integer X out to PORT
+
+(define (write-number x port)
+  (write-number-no-newline x port)
+  (write-char '#\newline port))
+
+(define (write-number-no-newline x port)
+  (let ((x (cond ((< x 0)
+                  (write-char '#\- port)
+                  (- 0 x))
+                 (else
+                  x))))
+    (let loop ((x x) (mask (integer-mask x)))
+      (let ((digit (quotient x mask)))
+        (write-char (ascii->char (+ digit (char->ascii '#\0))) port)
+        (if (> mask 1)
+	    (loop (remainder x mask) (quotient mask 10)))))))
+
+
+
+		
diff --git a/ps-compiler/prescheme/test/simp.scm b/ps-compiler/prescheme/test/simp.scm
new file mode 100644
index 0000000..ba1bd4b
--- /dev/null
+++ b/ps-compiler/prescheme/test/simp.scm
@@ -0,0 +1,19 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define (foo x y z)
+  (if (and (= (bitwise-and x 3) 0)
+	   (= (bitwise-and y 3) 0)
+	   (= (bitwise-and z 3) 0))
+      (ashl (ashr x 2) 2)
+      (ashl y (ashr z 2))))
+
+(define-local-syntax (define-primitive id nargs)
+  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
+    `(define (,id . ,args)
+       (call-primitively ,id . ,args))))
+
+(define-primitive = 2)
+(define-primitive bitwise-and 2)
+(define-primitive ashl 2)
+(define-primitive ashr 2)
diff --git a/ps-compiler/prescheme/test/string.scm b/ps-compiler/prescheme/test/string.scm
new file mode 100644
index 0000000..4874101
--- /dev/null
+++ b/ps-compiler/prescheme/test/string.scm
@@ -0,0 +1,54 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+
+(define (xwrite-string string out)
+  (let ((len (string-length string)))
+    (do ((i 0 (+ i 1)))
+	((>= i len))
+      (write-char (string-ref string (- len (+ i 1))) out))
+    (newline out)))
+
+(define (write-string string out)
+  (let ((len (string-length string)))
+    (do ((i 0 (+ i 1)))
+	((>= i len))
+      (write-char (string-ref string i) out))
+    (newline out)))
+
+(define a-string "Hello sailor...")
+
+(define (test)
+  (let* ((in (current-input-port))
+	 (out (current-output-port))
+	 (len (ashr (read-number in) 2))
+	 (string (make-string len)))
+    (let loop ((i 0))
+      (if (< i len)
+	  (ps-read-char in
+	    (lambda (ch)
+	      (string-set! string i ch)
+	      (loop (+ i 1)))
+	    (lambda ()
+	      (unassigned)))))
+    (write-string string out)
+    (xwrite-string string out)
+    (deallocate string)
+    (write-string a-string out)
+    (xwrite-string a-string out)))
+
+(define (read-number port)
+  (let loop ((r 0))
+    (ps-read-char port
+      (lambda (ch)
+	(cond ((digit? ch)
+	       (loop (+ (- (char->ascii ch) (char->ascii #\0))
+			(* r 10))))
+	      (else r)))
+      (lambda () 0))))
+
+(define (digit? ch)
+  (let ((ch (char->ascii ch)))
+    (and (>= ch (char->ascii #\0))
+	 (<= ch (char->ascii #\9)))))
+
diff --git a/ps-compiler/prescheme/test/test.scm b/ps-compiler/prescheme/test/test.scm
new file mode 100644
index 0000000..9a5930b
--- /dev/null
+++ b/ps-compiler/prescheme/test/test.scm
@@ -0,0 +1,72 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+
+(define (test x)
+  (cond ((= x 1)
+	 (goto raise-exception 2))
+	((= x 2)
+	 (goto raise-exception1 2 0))
+	((= x 3)
+	 (goto raise-exception 3))
+	((= x 4)
+	 (goto raise-exception1 4 0))))
+
+(define *code-pointer* 0)
+(define *stack* 0)
+
+(define (push x)
+  (vector-set! *stack* 0 x)
+  (set! *stack* (- *stack* 4)))
+
+(define (fetch-byte address)
+  (byte-vector-ref address 0))
+
+(define (current-opcode code-args)
+  (fetch-byte (- *code-pointer* (+ code-args 1))))
+
+(define (start-exception args)
+  (push (current-opcode args)))
+
+(define (raise-exception args)
+  (start-exception args)
+  (goto raise 0))
+
+(define (raise-exception1 args a1)
+  (start-exception args)
+  (push a1)
+  (goto raise 1))
+
+(define (raise n)
+  (goto test n))
+
+(define-local-syntax (define-primitive id nargs)
+  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
+    `(define (,id . ,args)
+       (call-primitively ,id . ,args))))
+
+(define-local-syntax (define-effect-primitive id nargs)
+  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
+    `(define (,id . ,args)
+       (call-primitively ,id . ,args)
+       (call-primitively undefined-value))))
+
+(define-primitive + 2)
+(define-primitive - 2)
+(define-primitive * 2)
+(define-primitive < 2)
+(define-primitive = 2)
+
+(define-primitive quotient  2)
+(define-primitive remainder 2)
+
+(define (unassigned) (call-primitively undefined-value))
+
+(define (byte-vector-ref vec index)
+  (call-primitively byte-contents (+ vec index)))
+
+(define (byte-vector-set! vec index value)
+  (call-primitively byte-set-contents! (+ vec index) value))
+
+(define (vector-set! vec index value)
+  (call-primitively set-contents! (+ vec (* index 4)) value))
diff --git a/ps-compiler/prescheme/test/values.scm b/ps-compiler/prescheme/test/values.scm
new file mode 100644
index 0000000..3a8fdf3
--- /dev/null
+++ b/ps-compiler/prescheme/test/values.scm
@@ -0,0 +1,11 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define (sender)
+  (values 1 2 3 4))
+
+(define (receiver a b c d)
+  (+ a (- b (* c d))))
+
+(define (test)
+  (call-with-values sender receiver))
diff --git a/ps-compiler/prescheme/test/vector.scm b/ps-compiler/prescheme/test/vector.scm
new file mode 100644
index 0000000..2918e72
--- /dev/null
+++ b/ps-compiler/prescheme/test/vector.scm
@@ -0,0 +1,32 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+; Oops - this is polymorphic!
+
+(define (vector+length-fill! v length x)
+  (do ((i 0 (+ i 1)))
+      ((>= i length))
+    (vector-set! v i x)))
+
+(define *v* (unassigned))
+
+(define (test x)
+  (set! *v* (make-vector 10))
+  (vector+length-fill! *v* 10 3)
+  (vector-ref *v* x))
+
+;(define (find-port-index)
+;  (let loop ((i 0))
+;    (cond ((>= i 10)
+;           -1)
+;          ((= 3 (vector-ref *v* i))
+;           i)
+;          (else (loop (+ i 1))))))
+;
+;(define (foo)
+;  (let loop ((i (find-port-index)))
+;    (if (>= i 5)
+;        (let ((v *v*))
+;          (bar)
+;          (vector-set! v i (baz)))
+;        (loop (find-port-index)))))
diff --git a/ps-compiler/prescheme/test/vector2.scm b/ps-compiler/prescheme/test/vector2.scm
new file mode 100644
index 0000000..895b5c7
--- /dev/null
+++ b/ps-compiler/prescheme/test/vector2.scm
@@ -0,0 +1,34 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define-local-syntax (define-primitive id nargs)
+  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
+    `(define (,id . ,args)
+       (call-primitively ,id . ,args))))
+
+(define-primitive + 2)
+(define-primitive - 2)
+(define-primitive * 2)
+(define-primitive < 2)
+
+(define-primitive make-vector 2)
+(define-primitive pointer-add 2)
+
+(define (vector-ref vec index)
+  (call-primitively contents (pointer-add vec index)))
+
+(define (vector-set! vec index value)
+  (call-primitively set-contents! (pointer-add vec index) value))
+
+(define (cons x y)
+  (let ((p (make-vector 2 0)))
+    (vector-set! p 0 x)
+    (vector-set! p 1 y)
+    p))
+
+(define (car p)
+  (vector-ref p 0))
+
+(define (cdr p)
+  (vector-ref p 1))
+
diff --git a/ps-compiler/prescheme/test/write.scm b/ps-compiler/prescheme/test/write.scm
new file mode 100644
index 0000000..5cd0c26
--- /dev/null
+++ b/ps-compiler/prescheme/test/write.scm
@@ -0,0 +1,19 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define (test)
+  (let* ((b (allocate-memory 16))
+	 (res (read-block (current-input-port)
+			  b
+			  16
+			  (lambda (okay? eof? got)
+			    (if (or (not okay?)
+				    eof?)
+				-1
+				(write-block (current-output-port)
+					     b
+					     got
+					     (lambda (okay? sent)
+					       (if okay? sent -1))))))))
+    (deallocate-memory b)
+    res))
diff --git a/ps-compiler/prescheme/to-cps.scm b/ps-compiler/prescheme/to-cps.scm
new file mode 100644
index 0000000..9a8cdd6
--- /dev/null
+++ b/ps-compiler/prescheme/to-cps.scm
@@ -0,0 +1,631 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+; Convert a byte-code-compiler node into a cps node.
+
+; Entry point.
+
+(define (x->cps node name)
+  (receive (value first-call last-lambda)
+      (cps node)
+    (if first-call
+	(bug "(X->CPS ~S) got a non-value" node))
+    (maybe-add-name! value name)
+    value))
+
+;----------------------------------------------------------------
+; (CPS <node>)
+;   -> <value> <first-call> <last-lambda>
+; <value> is the CPSed value of <node>.  If <node> contains no non-trivial
+; calls, <first-call> and <last-lambda> are both #f.  Otherwise they are
+; the first of the non-trivial calls and the continuation of the last.
+
+(define (cps node)
+  (receive (value first-call last-lambda)
+      (real-cps node)
+    (let ((value (cond ((not (list? value))
+			value)
+		       ((or (null? value)
+			    (not (null? (cdr value))))
+			(bug "value expression did not return one value ~S"
+			     (schemify node)))
+		       (else
+			(car value)))))
+      (values value first-call last-lambda))))
+    
+; Same as above except that <value> is a list of values.
+
+(define (values-cps node)
+  (receive (value first-call last-lambda)
+      (real-cps node)
+    (values (if (list? value)
+		value
+		(list value))
+	    first-call
+	    last-lambda)))
+
+(define (real-cps node)
+  ((operator-table-ref cps-converters
+		       (node-operator-id node))
+     node))
+
+(define cps-converters
+  (make-operator-table
+   (lambda (node id)
+     (error "no cps-converter for node ~S" node))))
+
+(define (define-cps-converter name proc)
+  (operator-define! cps-converters name #f proc))
+
+;----------------------------------------------------------------
+; (TAIL-CPS <node> <continuation-variable>)
+;   -> <first-call>
+
+(define (tail-cps node cont-var)
+  ((operator-table-ref tail-cps-converters (node-operator-id node))
+     node
+     cont-var))
+
+(define tail-cps-converters
+  (make-operator-table
+    (lambda (node cont-var)
+      (error "no tail-cps-converter for node ~S" node))))
+
+(define (define-tail-cps-converter name proc)
+  (operator-define! tail-cps-converters name #f proc))
+
+; Use PROC in the CPS table and give it a wrapper that makes a return for use
+; in the TAIL-CPS table.
+
+(define (define-value-cps-converter name proc)
+  (operator-define! cps-converters name #f
+		    (lambda (node)
+		      (values (proc node) #f #f)))
+  (operator-define! tail-cps-converters name #f
+		    (lambda (node cont-var)
+		      (make-return cont-var (proc node)))))
+
+; El Hacko Grande: we use the name of the CONT-VAR to determine whether
+; it is a return or a join point.
+
+(define (join? var)
+  (case (variable-name var)
+    ((c) #f)
+    ((j) #t)
+    (else
+     (bug "funny continuation variable name ~S" var))))
+
+(define (make-return cont-var value)
+  (really-make-return cont-var (list value)))
+
+(define (make-multiple-value-return cont-var values)
+  (really-make-return cont-var values))
+
+(define (really-make-return cont-var values)
+  (let ((return (make-call-node
+		 (get-primop (if (join? cont-var)
+				 (enum primop jump)
+				 (enum primop unknown-return)))
+		 (+ 1 (length values))
+		 0)))
+    (attach-call-args return (cons (make-reference-node cont-var) values))
+    return))
+
+;----------------------------------------------------------------
+; Constants are easy.
+
+(define-value-cps-converter 'literal
+  (lambda (node)
+    (cps-literal (node-form node) node)))
+
+(define-value-cps-converter 'quote
+  (lambda (node)
+    (cps-literal (cadr (node-form node)) node)))
+
+(define (cps-literal value node)
+  (make-literal-node value (node-type node)))
+
+(define-value-cps-converter 'unspecific
+  (lambda (node)
+    (make-unspecific)))
+
+(define (make-unspecific)
+  (make-call-node (get-prescheme-primop 'unspecific) 0 0))
+
+; Used for primitives in non-call position.  The CDR of the form is a
+; variable that will be bound to the primitive's closed-compiled value.
+
+(define-value-cps-converter 'primitive
+  (lambda (node)
+    (make-reference-node (cdr (node-form node)))))
+
+;----------------------------------------------------------------
+
+(define-value-cps-converter 'lambda
+  (lambda (node)
+    (let ((form (node-form node))
+	  (cont-var (make-variable 'c (lambda-node-return-type node)))
+	  (vars (map (lambda (name)
+		       (let ((var (make-variable (name-node->symbol name)
+						 (node-type name))))
+			 (node-set! name 'variable var)
+			 var))
+		     (cadr (node-form node)))))
+      (let ((lnode (make-lambda-node 'p 'proc (cons cont-var vars))))
+	(attach-body lnode (tail-cps (caddr form) cont-var))
+	lnode))))
+
+;----------------------------------------------------------------
+; References and SET!
+
+(define-value-cps-converter 'name
+  (lambda (node)
+    (cond ((node-ref node 'variable)
+	   => make-reference-node)    ; eventually have to check for SET!'s
+	  ((node-ref node 'binding)
+	   => (lambda (binding)
+		(let ((var (binding-place binding)))
+		  (cond ((not (variable? var))
+			 (bug "binding for ~S has funny place ~S" node var))
+			((variable-set!? var)
+			 (make-global-ref var))
+			(else
+			 (make-reference-node var))))))
+	  (else
+	   (bug "name node ~S has neither variable nor binding" node)))))
+  
+(define (make-global-ref var)
+  ((structure-ref node let-nodes)
+     ((call (global-ref 0 (* var))))
+   call))
+
+; Stolen from form.scm as an expedient.  This needs to be moved to somewhere
+; that both FORMS and TO-CPS can see it.
+
+(define (variable-set!? var)
+  (memq 'set! (variable-flags var)))
+
+(define-cps-converter 'set!
+  (lambda (node)
+    (receive (first-call last-lambda)
+	(make-global-set! (node-form node))
+      (values (make-unspecific) first-call last-lambda))))
+
+(define-tail-cps-converter 'set!
+  (lambda (node cont-var)
+    (receive (first-call last-lambda)
+	(make-global-set! (node-form node))
+      (attach-body last-lambda (make-return cont-var (make-unspecific)))
+      first-call)))
+
+(define (make-global-set! form)
+  (let ((name (cadr form))
+	(value (caddr form)))
+    (receive (value first-call last-lambda)
+	(cps value)
+      (maybe-add-name! value name)
+      (let ((cont (make-lambda-node 'c 'cont '()))
+	    (var (name-node->variable name)))
+	((structure-ref node let-nodes)
+	 ((call (global-set! 1 cont (* var) value)))
+	 (values (splice!->first first-call last-lambda call)
+		 cont))))))
+
+(define (name-node->variable name-node)
+  (let ((binding (node-ref name-node 'binding)))
+    (if (and binding
+             (variable? (binding-place binding)))
+        (binding-place binding)
+	(bug "name node ~S has no variable" name-node))))
+
+;----------------------------------------------------------------
+; CALL & GOTO
+
+(define-cps-converter 'call
+  (lambda (node)
+    (let ((exp (node-form node)))
+      (convert-call (car exp) (cdr exp) node))))
+
+; Treat non-tail-recursive GOTO's as normal calls.
+
+(define-cps-converter 'goto
+  (lambda (node)
+    (let ((exp (node-form node)))
+      (user-warning "Ignoring non-tail-recursive GOTO: ~S" (schemify node))
+      (convert-call (cadr exp) (cddr exp) node))))
+
+; Dispatch on the procedure.  Do something special with lambdas, primitives,
+; primops (in literal nodes).  Everything else is turned into an unknown call.
+; Calls to primitives are expanded and then CPS'ed.
+
+(define (convert-call proc args node)
+  (cond ((lambda-node? proc)
+	 (convert-let (node-form proc) args node))
+	((primitive-node? proc)
+	 (values-cps (expand-primitive-call proc args node)))
+	((and (literal-node? proc)
+	      (primop? (node-form proc)))
+	 (convert-primop-call (node-form proc) args (node-type node)))
+	(else
+	 (convert-primop-call (get-primop (enum primop unknown-call))
+			      (cons proc    ; add protocol argument
+				    (cons (make-literal normal-protocol)
+					  args))
+			      (node-type node)))))
+
+; Same again, except that for unknown tail-recursive calls we use different
+; protocols for CALL and GOTO.
+
+(define-tail-cps-converter 'call
+  (lambda (node cont-var)
+    (if (join? cont-var)
+	(convert-and-add-jump node cont-var)
+	(let ((exp (node-form node)))
+	  (tail-convert-call (car exp) (cdr exp) node cont-var normal-protocol)))))
+
+(define-tail-cps-converter 'goto
+  (lambda (node cont-var)
+    (if (join? cont-var)
+	(convert-and-add-jump node cont-var)
+	(let ((exp (node-form node)))
+	  (tail-convert-call (cadr exp) (cddr exp) node cont-var goto-protocol)))))
+
+(define (convert-and-add-jump node join-var)
+  (receive (values first-call last-lambda)
+      (values-cps node)
+    (let ((jump (make-multiple-value-return join-var values)))
+      (cond (first-call
+	     (attach-body last-lambda jump)
+	     first-call)
+	    (else
+	     jump)))))
+
+(define (tail-convert-call proc args node cont-var protocol)
+  (cond ((lambda-node? proc)
+	 (convert-tail-let (node-form proc) args node cont-var))
+	((primitive-node? proc)
+	 (tail-cps (expand-primitive-call proc args node)
+		   cont-var))
+	((and (literal-node? proc)
+	      (primop? (node-form proc)))
+	 (convert-primop-tail-call (node-form proc) args cont-var))
+	(else
+	 (convert-unknown-tail-call (cons proc args) cont-var protocol))))
+
+; Every primitive has its own expander.
+
+(define (expand-primitive-call proc args node)
+  ((primitive-expander (node-form proc)) args (node-type node)))
+
+(define lambda-node? (node-predicate 'lambda))
+(define primitive-node? (node-predicate 'primitive))
+(define literal-node? (node-predicate 'literal))
+
+(define literal-op (get-operator 'literal))
+
+(define (make-literal value)
+  (make-node literal-op value))
+
+;----------------------------------------------------------------
+; LET (= a call whose procedure is a LAMBDA)
+
+; REALLY-CONVERT-LET does all the work.  These convert the body of the LET
+; using either CPS or TAIL-CPS and connect everything up.
+
+(define (convert-let proc args node)
+  (receive (lnode first-call)
+      (really-convert-let proc args node)
+    (receive (vals body-first-call body-last-lambda)
+	(values-cps (caddr proc))
+      (values vals
+	      first-call
+	      (splice!->last lnode body-first-call body-last-lambda)))))
+	
+(define (convert-tail-let proc args node cont-var)
+  (receive (lnode first-call)
+      (really-convert-let proc args node)
+    (attach-body lnode (tail-cps (caddr proc) cont-var))
+    first-call))
+
+;  Make the call to the LET primop and build the lambda node for the procedure.
+
+(define (really-convert-let proc args node)
+  (receive (call first-call last-lambda)
+      (cps-call (get-primop (enum primop let)) 1 1 args cps)
+    (let ((vars (map (lambda (name)
+		       (let ((var (make-variable (name-node->symbol name)
+						 (node-type name))))
+			 (node-set! name 'variable var)
+			 var))
+		     (cadr proc))))
+      (do ((names (cadr proc) (cdr names))
+	   (index 1 (+ index 1)))
+	  ((null? names))
+	(maybe-add-argument-name! call index (node-form (car names))))
+      (let ((lnode (make-lambda-node #f 'cont vars)))
+	(attach call 0 lnode)
+	(values lnode (splice!->first first-call last-lambda call))))))
+
+; Primitive calls
+; Use CPS-CALL to do the work and then make a continuation if the primop is
+; not trivial.
+
+(define (convert-primop-call primop args type)
+  (let ((trivial? (primop-trivial? primop)))
+    (receive (call first-call last-lambda)
+	(cps-call primop (if trivial? 0 1) (if trivial? 0 1) args cps)
+      (if (not trivial?)
+	  (add-continuation call first-call last-lambda type)
+	  (values call first-call last-lambda)))))
+
+(define (add-continuation call first-call last-lambda type)
+  (let* ((vars (map (lambda (type)
+		      (make-variable 'v type))
+		    (if (tuple-type? type)
+			(tuple-type-types type)
+			(list type))))
+	 (cont (make-lambda-node 'c 'cont vars)))
+    (attach call 0 cont)
+    (values (if (tuple-type? type)
+		(map make-reference-node vars)
+		(make-reference-node (car vars)))
+	    (splice!->first first-call last-lambda call)
+	    cont)))
+
+; Call CONVERT-PRIMOP-CALL and then make a return.
+
+(define (convert-primop-tail-call primop args cont-var)
+  (receive (value first-call last-lambda)
+      (convert-primop-call primop args (variable-type cont-var))
+    (splice!->first first-call
+		    last-lambda
+		    (if (list? value)
+			(make-multiple-value-return cont-var value)
+			(make-return cont-var value)))))
+
+; Another front for CPS-CALL, passing it the UNKNOWN-TAIL-CALL primop and
+; its arguments, which are the procedure being called, the protocol, and
+; the actual arguments.
+
+(define (convert-unknown-tail-call args cont-var protocol)
+  (receive (call first-call last-lambda)
+      (cps-call (get-primop (enum primop unknown-tail-call)) 0 1
+		(cons (car args)
+		      (cons (make-literal protocol) (cdr args)))
+		cps)
+    (attach call 0 (make-reference-node cont-var))
+    (splice!->first first-call last-lambda call)))
+
+;----------------------------------------------------------------
+; BEGIN
+; These are fronts for CPS-SEQUENCE.
+
+(define-cps-converter 'begin
+  (lambda (node)
+    (receive (last-node real-first-call last-lambda)
+	(cps-sequence (cdr (node-form node)) values-cps)
+      (if (not real-first-call)
+	  (cps last-node)
+	  (receive (vals first-call real-last-lambda)
+	      (values-cps last-node)
+	    (values vals
+		    real-first-call
+		    (splice!->last last-lambda first-call real-last-lambda)))))))
+
+(define-tail-cps-converter 'begin
+  (lambda (node cont-var)
+    (receive (last-node first-call last-lambda)
+	(cps-sequence (cdr (node-form node)) values-cps)
+      (splice!->first first-call last-lambda (tail-cps last-node cont-var)))))
+
+;----------------------------------------------------------------
+;
+; (IF <a> <b> <c>)
+;  =>
+; (LET ((J (LAMBDA (V) [rest-goes-here])))
+;   (TEST (LAMBDA () [tail-cps <b> J])
+;         (LAMBDA () [tail-cps <c> J])
+;         <a>))
+
+(define-cps-converter 'if
+  (lambda (node)
+    (let ((exp (node-form node))
+	  (join-var (make-variable 'j type/unknown))
+	  (res-vars (make-variables (node-type node))))
+      (receive (call first-call last-lambda)
+	  (convert-if exp join-var)
+	(let ((let-lambda (make-lambda-node 'c 'cont (list join-var)))
+	      (let-call (make-call-node (get-primop (enum primop let)) 2 1))
+	      (join-lambda (make-lambda-node 'j 'jump res-vars)))
+	  (attach let-call 0 let-lambda)
+	  (attach let-call 1 join-lambda)
+	  (attach-body let-lambda call)
+	  (values (map make-reference-node res-vars)
+		  (splice!->first first-call last-lambda let-call )
+		  join-lambda))))))
+
+(define (make-variables type)
+  (map (lambda (type)
+	 (make-variable 'v type))
+       (if (tuple-type? type)
+	   (tuple-type-types type)
+	   (list type))))
+
+; Tail-recursive IFs do not require a join point.
+
+(define-tail-cps-converter 'if
+  (lambda (node cont-var)
+    (let ((exp (node-form node)))
+      (receive (call first-call last-lambda)
+	  (convert-if exp cont-var)
+	(splice!->first first-call last-lambda call)))))
+
+; Actually build the two-continuation call to the TEST primop.
+
+(define (convert-if exp cont-var)	
+  (receive (call first-call last-lambda)
+      (cps-call (get-prescheme-primop 'test) 2 2 (list (cadr exp)) cps)
+    (let ((true-cont (make-lambda-node 'c 'cont '()))
+	  (true-call (tail-cps (caddr exp) cont-var))
+	  (false-cont (make-lambda-node 'c 'cont '()))
+	  (false-call (tail-cps (cadddr exp) cont-var)))
+      (attach-body true-cont true-call)
+      (attach-body false-cont false-call)
+      (attach call 0 true-cont)
+      (attach call 1 false-cont)
+      (values call first-call last-lambda))))
+
+;----------------------------------------------------------------
+
+(define-cps-converter 'values
+  (lambda (node)
+    (let ((args (cdr (node-form node))))
+      (receive (call first-call last-lambda)
+	  (cps-call (get-prescheme-primop 'unspecific) 0 0 args cps)
+	(let ((vals (vector->list (call-args call))))
+	  (map detach vals)
+	  (values vals first-call last-lambda))))))
+	  
+(define-tail-cps-converter 'values
+  (lambda (node cont-var)
+    (let ((args (cdr (node-form node))))
+      (receive (call first-call last-lambda)
+	  (cps-call (get-primop (enum primop unknown-return)) 0 1 args cps)
+	(attach call 0 (make-reference-node cont-var))
+	(splice!->first first-call last-lambda call)))))
+	  
+(define-cps-converter 'call-with-values
+  (lambda (node)
+    (convert-call-with-values node #f)))
+
+(define-tail-cps-converter 'call-with-values
+  (lambda (node cont-var)
+    (convert-call-with-values node cont-var)))
+
+; Consumer is known to be a lambda node.
+
+(define (convert-call-with-values node maybe-cont-var)
+  (receive (vals first-call last-lambda)
+      (values-cps (cadr (node-form node)))
+    (let ((consumer (x->cps (caddr (node-form node)) #f))
+	  (call (make-call-node (get-primop (if maybe-cont-var
+						(enum primop tail-call)
+						(enum primop call)))
+				(+ 2 (length vals))
+				(if maybe-cont-var 0 1))))
+      (attach-call-args call `(#f ,consumer . ,vals))
+      (cond (maybe-cont-var
+	     (attach call 0 (make-reference-node maybe-cont-var))
+	     (splice!->first first-call last-lambda call))
+	    (else
+	     (add-continuation call first-call last-lambda (node-type node)))))))
+
+;----------------------------------------------------------------
+; LETRECs have been analyzed and restructured by FLATTEN, so we know that
+; the values are all lambdas.
+
+(define-cps-converter 'letrec
+  (lambda (node)
+    (let ((form (node-form node)))
+      (receive (first-call last-lambda)
+	  (convert-letrec form)
+	(receive (vals body-first-call body-last-lambda)
+	    (values-cps (caddr form))
+	  (values vals
+		  first-call
+		  (splice!->last last-lambda
+				 body-first-call
+				 body-last-lambda)))))))
+
+(define-tail-cps-converter 'letrec
+  (lambda (node cont-var)
+    (let ((form (node-form node)))
+      (receive (first-call last-lambda)
+	  (convert-letrec form)
+	(attach-body last-lambda (tail-cps (caddr form) cont-var))
+	first-call))))
+
+(define (convert-letrec form)
+  (let ((vars (map (lambda (l)
+		     (let ((var (make-variable (name-node->symbol (car l))
+					       (node-type (car l)))))
+		       (node-set! (car l) 'variable var)
+		       var))
+		   (cadr form)))
+	(vals (map (lambda (l)
+		     (receive (value first-call last-lambda)
+			 (cps (cadr l))
+		       value))
+		   (cadr form)))
+	(cont (make-lambda-node 'c 'cont '())))
+    ((structure-ref node let-nodes)
+       ((top (letrec1 1 l1))
+        (l1 ((x #f) . vars) call2)
+        (call2 (letrec2 1 cont (* x) . vals)))
+      (do ((names (cadr form) (cdr names))
+	   (index 2 (+ index 1)))
+	  ((null? names))
+	(maybe-add-argument-name! call2 index (node-form (caar names))))
+      (values top cont))))
+
+;----------------------------------------------------------------
+; Utilities.
+
+; Stuff is a list of alternating call and lambda nodes, with possible #Fs.
+; This joins the nodes together by making the calls be the bodies of the
+; lambdas (the call->lambda links are already done).  The last node is
+; returned.
+
+(define (splice! stuff)
+  (let loop ((stuff stuff) (first #f) (last #f))
+    (if (null? stuff)
+	(values first last)
+	(receive (first last)
+	    (let ((next (car stuff)))
+	      (cond ((not next)
+		     (values first last))
+		    ((not first)
+		     (values next next))
+		    (else
+		     (if (and ((structure-ref node lambda-node?) last)
+			      ((structure-ref node call-node?) next))
+			 (attach-body last next))
+		     (values first next))))
+	  (loop (cdr stuff) first last)))))
+
+(define (splice!->first . stuff)
+  (receive (first last)
+      (splice! stuff)
+    first))
+
+(define (splice!->last . stuff)
+  (receive (first last)
+      (splice! stuff)
+    last))
+
+; Stuff for making CPS nodes
+(define make-reference-node (structure-ref node make-reference-node))
+(define make-lambda-node    (structure-ref node make-lambda-node))
+(define make-literal-node   (structure-ref node make-literal-node))
+(define make-call-node      (structure-ref node make-call-node))
+(define attach              (structure-ref node attach))
+(define detach              (structure-ref node detach))
+(define attach-body         (structure-ref node attach-body))
+(define attach-call-args    (structure-ref node attach-call-args))
+(define call-args           (structure-ref node call-args))
+
+; Adding names to lambda nodes for debugging help.
+
+(define (maybe-add-argument-name! call index name)
+  (maybe-add-name! ((structure-ref node call-arg) call index) name))
+
+(define (maybe-add-name! value name)
+  (if ((structure-ref node lambda-node?) value)
+      ((structure-ref node set-lambda-name!) value (schemify name))))
+
+; Getting symbols for use as variable names.
+
+(define (name-node->symbol node)
+  (let ((name (node-form node)))
+    (if (generated? name)
+	(generated-symbol name)
+	name)))
diff --git a/ps-compiler/prescheme/top.scm b/ps-compiler/prescheme/top.scm
new file mode 100644
index 0000000..6b40f7d
--- /dev/null
+++ b/ps-compiler/prescheme/top.scm
@@ -0,0 +1,318 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+; Entry point
+
+(define (prescheme-compiler package-id spec-files init-name c-file . commands)
+  (reset-node-id)
+  (initialize-lambdas)
+  (reset-record-data!)
+  (reset-type-vars!)
+  (receive (copy no-copy shadow integrate header)
+      (parse-prescheme-commands commands)
+    (let ((forms (prescheme-front-end (if (list? package-id)
+					  package-id
+					  (list package-id))
+				      spec-files copy no-copy shadow)))
+      (for-each simplify-form forms)
+      (let ((forms (remove-unreferenced-forms forms)))
+	(for-each integrate-stob-form forms) 
+	; prevent further automatic integration
+	(for-each (lambda (form)
+		    (remove-variable-known-value! (form-var form)))
+		  forms)
+	(integrate-by-command integrate forms)
+	(for-each resimplify-form forms)
+	(let* ((forms (remove-unreferenced-forms forms))
+	       (forms (integrate-single-uses forms))
+	       (forms (remove-unreferenced-forms forms)))
+	  (for-each resimplify-form forms)
+	  (for-each determine-form-protocol forms)
+	  (let ((forms (form-tail-calls->jumps forms)))
+	    (for-each maybe-add-self-label forms)
+	    (let ((forms (hoist-nested-procedures forms)))
+	      (for-each remove-polymorphism forms)
+	      ; (if cps-file (write-cps-file cps-file forms))
+	      (if c-file (write-c-file init-name c-file header forms)))))))))
+
+;(define (expand-and-eval-program package-id spec-files output-file . commands)
+;  (reset-node-id)
+;  (reset-record-data!)
+;  (receive (copy no-copy shadow integrate header)
+;      (parse-prescheme-commands commands)
+;    (let ((forms (prescheme-front-end package-id spec-files copy no-copy shadow)))
+;      (call-with-output-file output-file
+;        (lambda (out)
+;          (display-forms-as-scheme forms out))))))
+
+;(define (simplify-and-print-program package-id spec-files output-file c-file . commands)
+;  (reset-node-id)
+;  (reset-record-data!)
+;  (receive (copy no-copy shadow integrate header)
+;      (parse-prescheme-commands commands)
+;    (let ((forms (prescheme-front-end package-id spec-files copy no-copy shadow)))
+;      (for-each simplify-form forms)
+;      (let ((forms (remove-unreferenced-forms forms)))
+;        (call-with-output-file output-file
+;          (lambda (out)
+;            (display-cps-forms-as-scheme forms out)))))))
+
+(define command-names '(copy no-copy shadow integrate header))
+
+(define (parse-prescheme-commands commands)
+  (let ((res (map list command-names)))
+    (for-each (lambda (command)
+		(cond ((assq (car command) res)
+		       => (lambda (l)
+			    (set-cdr! l (append (reverse (cdr command))
+						(cdr l)))))
+		      (else
+		       (error "unknown directive ~S" command))))
+	      commands)
+    (apply values (map (lambda (l) (reverse (cdr l))) res))))
+
+;--------------------------------------------------
+
+(define (simplify-form form)
+  (format #t " ~A " (form-name form))
+  (let ((status (expand-and-simplify-form form)))
+    (if status
+	(format #t "(~A): " status)
+	(format #t ": "))
+    (display-type (variable-type (form-var form))
+		  (current-output-port))
+    (newline (current-output-port))))
+
+;--------------------------------------------------
+
+(define (integrate-single-uses forms)
+  (format #t "In-lining single-use procedures~%")
+  (let loop ((forms forms) (done '()) (hit? #f))
+    (cond ((null? forms)
+	   (if hit?
+	       (loop (reverse done) '() #f)
+	       (reverse done)))
+	  ((single-called-use? (car forms))
+	   (let ((form (car forms)))
+;	     (format #t " ~S~%" (variable-name (form-var form)))
+	     (integrate-single-use form
+				   (car (variable-refs (form-var form)))
+				   #f)
+	     (set-form-value! form #f)
+	     (make-form-unused! form)
+	     (loop (cdr forms) done #t)))
+	  (else
+	   (loop (cdr forms) (cons (car forms) done) hit?)))))
+
+(define (single-called-use? form)
+  (let ((var (form-var form)))
+    (and (not (form-exported? form))
+	 (eq? (form-type form) 'lambda)
+	 (not (null? (variable-refs var)))
+	 (null? (cdr (variable-refs var)))
+	 (called-node? (car (variable-refs var))))))
+
+(define (integrate-single-use form ref copy?)
+  (let* ((in-node (node-base ref))
+	 (in-form (node-form in-node))
+	 (type (variable-type (form-var form))))
+    (use-this-form! in-form)
+    (let ((node (cond (copy?
+		       (copy-node-tree (form-node form)))
+		      (else
+		       (also-use-this-form! form)
+		       (form-node form)))))
+      (if (type-scheme? type)
+	  (if (not (called-node? ref))
+	      (error "integrating polymorphic value into non-call position")
+	      (instantiate-type&value type node ref)))
+      (determine-lambda-protocol node (list ref))
+      (replace ref node)
+      (simplify-all in-node (form-name form))
+      (suspend-form-use! in-form))))
+
+; Commands are (<proc> <caller>)
+
+(define (integrate-by-command commands forms)
+  (for-each (lambda (command)
+	      (receive (proc refs)
+		  (process-integrate-command command forms)
+		(if proc
+		    (for-each (lambda (r)
+				(integrate-single-use proc r #t))
+			      refs))))
+	    commands))
+
+; Horrendous error checking and notification.
+
+(define (process-integrate-command command forms)
+  (let* ((proc (any (lambda (f)
+		      (eq? (form-name f) (car command)))
+		    forms))
+	 (var (if proc (form-var proc) #f))
+	 (node (if proc (form-value proc) #f))
+	 (caller (any (lambda (f)
+			(eq? (form-name f) (cadr command)))
+		      forms))
+	 (refs (if (and var caller)
+		   (filter (lambda (ref)
+			     (eq? caller (node-form ref)))
+			   (variable-refs var))
+		   #f)))
+    (cond ((or (not proc) (not var) (not caller))
+	   (cond ((or (not proc) (not var))
+		  (format #t "Bad command: no value for ~S~%"
+			  (car command)))
+		 ((or (not node)
+		      (not (lambda-node? node)))
+		  (format #t "Bad command: ~S is not a procedure~%"
+			  (car command))))
+	   (if (not caller)
+	       (format #t "Bad command: no definition for ~S~%"
+		       (cadr command)))
+	   (values #f #f))
+	  ((or (null? refs) (not node) (not (lambda-node? node)))
+	   (if (null? refs)
+	       (format #t "Bad command: ~S is not referenced by ~S~%"
+		       (car command) (cadr command)))
+	   (if (or (not node)
+		   (not (lambda-node? node)))
+	       (format #t "Bad command: ~S is not a procedure~%"
+		       (car command)))
+	   (values #f #f))
+	  (else
+	   (values proc refs)))))
+
+;--------------------------------------------------
+
+(define (determine-form-protocol form)
+  (let ((var (form-var form)))
+    (cond ((and (not (form-exported? form))
+		(eq? 'lambda (form-type form))
+		(every? called-node? (variable-refs var)))
+	   (determine-lambda-protocol (form-node form) (variable-refs var))
+	   (note-known-global-lambda! var (form-node form))))))
+
+;--------------------------------------------------
+
+(define (form-tail-calls->jumps forms)
+  (receive (hits useless)
+      (find-jump-procs (filter-map (lambda (form)
+				     (if (eq? 'lambda (form-type form))
+					 (form-node form)
+					 #f))
+				   forms)
+		       find-form-proc-calls)
+    (for-each (lambda (p)
+		(let* ((procs (cdr p))
+		       (proc-forms (map node-form procs))
+		       (owner (node-flag (node-base (car p))))
+		       (vars (map form-var proc-forms)))
+		  (use-this-form! owner)
+		  (for-each also-use-this-form! proc-forms)
+		  (procs->jumps (cdr p) vars (car p))
+		  (simplify-node (form-value owner)) ; worth it?
+		  (suspend-form-use! owner)
+		  (for-each (lambda (f)
+			      (set-form-value! f #f)
+			      (make-form-unused! f))
+			    proc-forms)))
+	      hits)
+    (for-each (lambda (p)
+		(make-form-unused! (node-form p)))
+	      useless)
+    (filter (lambda (f)
+	      (not (eq? (form-type f) 'unused)))
+	    forms)))
+
+(define (find-form-proc-calls l)
+  (let ((refs (variable-refs (form-var (node-form l)))))
+    (cond ((and refs (every? called-node? refs))
+	   refs)
+	  ((calls-known? l)
+	   (bug "cannot find calls for known lambda ~S" l))
+	  (else #f))))
+
+;--------------------------------------------------
+; Determine an actual type for a polymorphic procedure.
+
+(define (remove-polymorphism form)
+  (if (and (null? (variable-refs (form-var form)))
+	   (eq? 'lambda (form-type form)))
+      (for-each (lambda (var)
+		  (if (and (null? (variable-refs var))
+			   (uvar? (maybe-follow-uvar (variable-type var))))
+		      (unused-variable-warning var form)))
+		(cdr (lambda-variables (form-node form)))))
+  (if (type-scheme? (variable-type (form-var form)))
+      (make-monomorphic! (form-var form))))
+
+(define (unused-variable-warning var form)		
+  (format #t "Warning: argument `~S' of `~S' is not used, and `~S' is not called;~%"
+	  (variable-name var) (form-name form) (form-name form))
+  (format #t "  assuming the type of argument `~S' of procedure `~S' is `long'.~%"
+	  (variable-name var) (form-name form))
+  (set-variable-type! var type/integer))
+
+;--------------------------------------------------
+
+; Various methods for getting values from thunks.  These are no longer used
+; here.
+
+(define (thunk-value thunk)
+  (let ((refs (variable-refs (car (lambda-variables thunk)))))
+    (if (= 1 (length refs))
+        (call-arg (node-parent (car refs)) 2)
+        #f)))
+
+(define (simple-thunk? thunk value)
+  (eq? (node-parent (node-parent value)) thunk))
+
+;----------------------------------------------------------------
+; Turning internal tail-recursive calls to jumps.
+
+; f = (proc (c . vars)
+;       ... ([unknown-]tail-call c f . args) ...)
+;  =>
+; f = (proc (c . vars)
+;       (letrec ((f' (jump . vars) ... (jump f' . args) ...))
+;         (jump f' . vars)))
+
+(define (maybe-add-self-label form)
+  (if (eq? 'lambda (form-type form))
+      (let* ((node (form-node form))
+	     (self-calls (filter (lambda (ref)
+				   (and (eq? (node-index ref) 1)
+					(calls-this-primop? (node-parent ref)
+							    (if (calls-known? node)
+								'tail-call
+								'unknown-tail-call))
+					(eq? node (node-base ref))))
+				 (variable-refs (form-var form)))))
+	(if (not (null? self-calls))
+	    (begin
+	      (use-this-form! form)
+	      (replace-self-calls-with-jumps node self-calls)
+	      (suspend-form-use! form))))))
+
+(define (replace-self-calls-with-jumps proc refs)
+  (let* ((outside-var (reference-variable (car refs)))
+	 (var (make-variable (variable-name outside-var)
+			     (variable-type outside-var)))
+	 (vars (map copy-variable (cdr (lambda-variables proc))))
+	 (args (map make-reference-node vars))
+	 (body (lambda-body proc))
+	 (jump-proc (make-lambda-node (lambda-name proc) 'jump vars)))
+    (for-each (lambda (ref)
+		(let ((call (node-parent ref)))
+		  (if (not (calls-known? proc))
+		      (remove-call-arg call 2))  ; remove TAIL? argument
+		  (remove-call-arg call 0)       ; remove continuation argument
+		  (replace (call-arg call 0) (make-reference-node var))
+		  (set-call-primop! call (get-primop (enum primop jump)))))
+	      refs)
+    (let-nodes ((call (jump 0 (* var) . args)))
+      (move-body body (lambda (body)
+			(attach-body jump-proc body)
+			call))
+      (put-in-letrec (list var) (list jump-proc) call))))
+    
diff --git a/ps-compiler/prescheme/type-scheme.scm b/ps-compiler/prescheme/type-scheme.scm
new file mode 100644
index 0000000..f066f1f
--- /dev/null
+++ b/ps-compiler/prescheme/type-scheme.scm
@@ -0,0 +1,107 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+; Type schemes
+
+(define-record-type type-scheme
+  (
+   type           ; a type
+   free-uvars     ; uvars that are free
+   )
+  ())
+
+(define make-type-scheme type-scheme-maker)
+
+(define-record-discloser type/type-scheme
+  (lambda (type-scheme)
+    (list 'type-scheme
+	  (map uvar-id (type-scheme-free-uvars type-scheme))
+	  (type-scheme-type type-scheme))))
+
+; If TYPE has any variables bound at DEPTH this returns a type scheme making
+; those variables polymorphic; otherwise TYPE is returned.
+
+; Would like to do limited finalizing of uvars, but can't.
+; Consider (lambda (g x) (tuple (g 3) (g x) x))
+; (a -> b) -> c -> [d, e, f] with
+; a > int8, d > b, a > c, e > b, f > c
+; No polymorphism, and no simplification without restricting someone
+; But consider NOT  a ->b, bool > a, b > bool
+; It could just as well be bool -> bool.
+; Simplification okay on variables that are not used inside other types?
+
+(define *free-uvars* '())
+
+(define (schemify-type type depth)
+  (set! *free-uvars* '())
+  (let* ((type (find-free-uvars type depth))
+	 (free-uvars *free-uvars*))
+    (set! *free-uvars* '()) ; drop pointers
+    (for-each (lambda (uvar)
+		(set-uvar-place! uvar #f))
+	      free-uvars)
+    (if (not (null? free-uvars))
+	(make-type-scheme type free-uvars)
+	type)))
+  
+(define (find-free-uvars type depth)
+  (let label ((type type))
+    (cond ((other-type? type)
+	   (make-other-type (other-type-kind type)
+			    (map label
+				 (other-type-subtypes type))))
+	  ((not (uvar? type))
+	   type)
+	  ((uvar-binding type)
+	   => label)
+	  ((and (not (uvar-place type))
+		(<= depth (uvar-depth type)))
+	   (set-uvar-place! type type)
+	   (set! *free-uvars* (cons type *free-uvars*))
+	   type)
+	  (else
+	   type))))
+
+; Instantiate SCHEME at DEPTH.
+;
+; New sequence:
+;   (instantiate-type-scheme scheme depth)
+;   ... elide bindings in new copy ...
+;   (clean-type-scheme scheme)
+
+(define (instantiate-type-scheme scheme depth . maybe-thunk)
+  (instantiate-type-scheme! scheme depth)
+  (let ((type (copy-type (type-scheme-type scheme))))
+    (if (not (null? maybe-thunk))
+	((car maybe-thunk)))
+    (clean-type-scheme! scheme)
+    type))
+
+(define (instantiate-type-scheme! scheme depth)
+  (let ((uid (unique-id)))
+    (for-each (lambda (uvar)
+		(set-uvar-place!
+		 uvar
+		 (make-uvar (uvar-prefix uvar) depth uid)))
+	      (type-scheme-free-uvars scheme))))
+
+(define (clean-type-scheme! scheme)
+  (for-each (lambda (uvar)
+	      (set-uvar-place! uvar #f))
+	    (type-scheme-free-uvars scheme)))
+
+(define (copy-type type)
+  (cond ((other-type? type)
+	 (make-other-type (other-type-kind type)
+			  (map copy-type
+			       (other-type-subtypes type))))
+	((not (uvar? type))
+	 type)
+	((uvar-place type)
+	 => identity)
+	((uvar-binding type)
+	 => copy-type)
+	(else
+	 type)))
+
+
diff --git a/ps-compiler/prescheme/type-var.scm b/ps-compiler/prescheme/type-var.scm
new file mode 100644
index 0000000..be9d28a
--- /dev/null
+++ b/ps-compiler/prescheme/type-var.scm
@@ -0,0 +1,149 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+; Type variables - what a mess
+
+(define-record-type uvar
+  (prefix        ; a name for debugging
+   (depth)       ; lexical depth of the uvar
+   id            ; a number
+   (tuple-okay?) ; true if this can be unified with a tuple, set when merged
+   )
+  ((place        #f)  ; used in producing type schemes
+   (source       #f)  ; to let the user know where this came from
+   (binding      #f)  ; known value of this uvar
+   (temp         #f)  ; useful field
+   ))
+
+(define-record-discloser type/uvar
+  (lambda (uvar)
+    (list 'uvar
+	  (uvar-prefix uvar)
+	  (uvar-depth uvar)
+	  (uvar-id uvar)
+	  (uvar-binding uvar))))
+
+(define (make-uvar prefix depth . maybe-id)
+  (uvar-maker prefix
+	      depth
+	      (if (null? maybe-id)
+		  (unique-id)
+		  (car maybe-id))
+	      #f))
+
+(define (make-tuple-uvar prefix depth . maybe-id)
+  (uvar-maker prefix
+	      depth
+	      (if (null? maybe-id)
+		  (unique-id)
+		  (car maybe-id))
+	      #t))
+
+; Could this safely short-circuit the chains?
+
+(define (maybe-follow-uvar type)
+  (cond ((and (uvar? type)
+	      (uvar-binding type))
+	 => maybe-follow-uvar)
+	(else type)))
+
+; Substitute VALUE for UVAR, if this will not introduce a circularity.
+; or cause other problems.  Returns an error-printing thunk if there is
+; a problem.
+
+(define (bind-uvar! uvar value)
+  (cond ((uvar? value)
+	 (bind-uvar-to-uvar! uvar value)
+	 #f)
+	(else
+	 (bind-uvar-to-type! uvar value))))
+
+(define (bind-uvar-to-uvar! uvar0 uvar1)
+  (minimize-type-depth! uvar1 (uvar-depth uvar0))
+  (set-uvar-binding! uvar0 uvar1)
+  (if (and (uvar-tuple-okay? uvar1)
+	   (not (uvar-tuple-okay? uvar0)))
+      (set-uvar-tuple-okay?! uvar1 #f)))
+
+(define (bind-uvar-to-type! uvar type)
+  (let ((errors '()))
+    (if (uvar-in-type? uvar type)
+	(set! errors (cons circularity-error errors)))
+    (if (and (tuple-type? type)
+	     (not (uvar-tuple-okay? uvar)))
+	(set! errors (cons (tuple-error type) errors)))
+    (cond ((null? errors)  ; whew!
+	   (minimize-type-depth! type (uvar-depth uvar))
+	   (set-uvar-binding! uvar type)
+	   #f)
+	  (else
+	   (lambda ()
+	     (format #t "unifying ")
+	     (display-type uvar (current-output-port))
+	     (format #t " == ")
+	     (display-type type (current-output-port))
+	     (format #t "~% would cause the following problem~A:"
+		     (if (null? (cdr errors)) "" "s"))
+	     (for-each (lambda (x) (x)) errors))))))
+		       
+(define (circularity-error)
+  (format #t "~% creation of a circular type"))
+
+(define (tuple-error type)
+  (lambda ()
+    (if (null? (tuple-type-types type))
+	(format #t "~% returning no values where one is expected")
+	(format #t "~% returning ~D values where one is expected"
+		(length (tuple-type-types type))))))
+
+; Check that UVAR does not occur in EXP.
+
+(define (uvar-in-type? uvar exp)
+  (let label ((exp exp))
+    (cond ((or (base-type? exp)
+	       (record-type? exp))
+	   #f)
+	  ((uvar? exp)
+	   (if (uvar-binding exp)
+	       (label (uvar-binding exp))
+	       (eq? exp uvar)))
+	  ((other-type? exp)
+	   (every? label (other-type-subtypes exp)))
+	  (else
+	   (identity (bug "funny type ~S" exp))))))
+  
+; Make the depths of any uvars in TYPE be no greater than DEPTH.
+
+(define (minimize-type-depth! type depth)
+  (let label ((type type))
+    (cond ((other-type? type)
+	   (for-each label (other-type-subtypes type)))
+	  ((uvar? type)
+	   (cond ((uvar-binding type)
+		  => label)
+		 ((< depth (uvar-depth type))
+		  (set-uvar-depth! type depth)))))))
+
+; Set the depth of all uvars in TYPE to be -1 so that it will not be made
+; polymorphic at any level.
+
+(define (make-nonpolymorphic! type)
+  (cond ((uvar? type)
+	 (set-uvar-depth! type -1))
+	((other-type? type)
+	 (for-each make-nonpolymorphic! (other-type-subtypes type)))
+	;((type-scheme? type)
+	; (make-nonpolymorphic! (type-scheme-type type)))
+	))
+
+;------------------------------------------------------------
+; Micro utilities
+
+(define *unique-id-counter* 0)
+
+(define (unique-id)
+  (set! *unique-id-counter* (+ *unique-id-counter* 1))
+  *unique-id-counter*)
+
+(define (reset-type-vars!)
+  (set! *unique-id-counter* 0))
diff --git a/ps-compiler/prescheme/type.scm b/ps-compiler/prescheme/type.scm
new file mode 100644
index 0000000..7725058
--- /dev/null
+++ b/ps-compiler/prescheme/type.scm
@@ -0,0 +1,233 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define-record-type base-type
+  (name
+   uid       ; an integer
+   )
+  ())
+
+(define-record-discloser type/base-type
+  (lambda (base-type)
+    (list (base-type-name base-type)
+	  (base-type-uid  base-type))))
+
+(define *next-base-type-uid* 0)
+
+(define (next-base-type-uid)
+  (let ((x *next-base-type-uid*))
+    (set! *next-base-type-uid* (+ x 1))
+    x))
+
+(define base-type-table (make-table))
+
+(define (make-base-type name)
+  (let ((type (base-type-maker name (next-base-type-uid))))
+    (table-set! base-type-table name type)
+    type))
+
+(define (lookup-type id)
+  (cond ((table-ref base-type-table id)
+	 => identity)
+	(else #f)))
+
+(define type/integer      (make-base-type 'integer))
+(define type/float        (make-base-type 'float))
+
+(define type/null         (make-base-type 'null))  ; no value
+(define type/unit         (make-base-type 'unit))  ; single value
+(define type/boolean      (make-base-type 'boolean))
+(define type/undetermined (make-base-type '?))
+(define type/input-port   (make-base-type 'input-port))
+(define type/output-port  (make-base-type 'output-port))
+(define type/address      (make-base-type 'address))
+(define type/char         (make-base-type 'char))
+
+(define (make-atomic-type name)
+  (base-type-maker name (next-base-type-uid)))
+
+(define type/unknown type/undetermined) ; an alias
+
+(define (type-name type)
+  (if (base-type? type)
+      (base-type-name type)
+      (error "type has no name ~S" type)))
+
+(define (make-base-type-table)
+  (let ((elts (make-vector *next-base-type-uid* #f)))
+    (values (lambda (type)
+	      (vector-ref elts (base-type-uid type)))
+	    (lambda (type value)
+	      (vector-set! elts (base-type-uid type) value)))))
+
+;--------------------------------------------------
+; This won't terminate on recursive types.
+
+(define (type-eq? type1 type2)
+  (let ((type1 (maybe-follow-uvar type1))
+	(type2 (maybe-follow-uvar type2)))
+    (or (eq? type1 type2)
+	(and (other-type? type1)
+	     (other-type? type2)
+	     (eq? (other-type-kind type1)
+		  (other-type-kind type2))
+	     (let loop ((l1 (other-type-subtypes type1))
+			(l2 (other-type-subtypes type2)))
+	       (cond ((null? l1) (null? l2))
+		     ((null? l2) #f)
+		     ((type-eq? (car l1) (car l2))
+		      (loop (cdr l1) (cdr l2)))
+		     (else #f)))))))
+
+;--------------------------------------------------
+; Arrow and pointer types (and perhaps others later)
+; All done together to simplify the type walking
+
+(define-record-type other-type
+  (
+   kind
+   (subtypes)       ; set when finalized
+   )
+  (
+   (finalized? #f)
+   ))
+
+(define make-other-type other-type-maker)
+
+(define-record-discloser type/other-type
+  (lambda (type)
+    (case (other-type-kind type)
+      ((arrow)
+       (list 'arrow-type
+	     (arrow-type-args type)
+	     (arrow-type-result type)))
+      (else
+       (cons (other-type-kind type)
+	     (other-type-subtypes type))))))
+
+(define (make-other-type-predicate kind)
+  (lambda (x)
+    (and (other-type? x)
+	 (eq? kind (other-type-kind x)))))
+
+; Arrow
+
+(define (make-arrow-type args result)
+  (other-type-maker 'arrow (cons result args)))
+
+(define arrow-type? (make-other-type-predicate 'arrow))
+
+(define (arrow-type-args type)
+  (cdr (other-type-subtypes type)))
+
+(define (arrow-type-result type)
+  (car (other-type-subtypes type)))
+
+; Pointer
+
+(define (make-pointer-type type)
+  (other-type-maker 'pointer (list type)))
+
+(define pointer-type? (make-other-type-predicate 'pointer))
+(define (pointer-type-to pointer-type)
+  (car (other-type-subtypes pointer-type)))
+
+(define type/string (make-pointer-type type/char))
+
+; Tuple (used for arguments and returning multiple values)
+
+(define (make-tuple-type types)
+  (if (and (not (null? types))
+	   (null? (cdr types)))
+      (car types)
+      (other-type-maker 'tuple types)))
+
+(define tuple-type? (make-other-type-predicate 'tuple))
+
+(define (tuple-type-types type)
+  (other-type-subtypes type))
+
+;--------------------------------------------------
+
+(define (finalize-type type)
+  (let ((type (maybe-follow-uvar type)))
+    (cond ((and (other-type? type)
+		(not (other-type-finalized? type)))
+	   (let ((subs (other-type-subtypes type)))
+	     (set-other-type-finalized?! type #t)
+	     (set-other-type-subtypes! type (map finalize-type subs))))
+	  ((and (uvar? type)               
+		(uvar-tuple-okay? type)) ; unused return value
+	   (bind-uvar! type type/unit)))
+    type))
+
+;--------------------------------------------------
+
+(define (expand-type-spec spec)
+  (cond ((pair? spec)
+	 (case (car spec)
+	   ((=>)
+	    (make-arrow-type (map expand-type-spec (cadr spec))
+			     (make-tuple-type (map expand-type-spec
+						   (cddr spec)))))
+	   ((^)
+	    (make-pointer-type (expand-type-spec (cadr spec))))
+	   ((tuple)
+	    (make-tuple-type (map expand-type-spec (cdr spec))))
+	   (else
+	    (error "unknown type syntax ~S" spec))))
+	((not (symbol? spec))
+	 (error "unknown type syntax ~S" spec))
+	((lookup-type spec)
+	 => identity)
+	((lookup-record-type spec)
+	 => make-pointer-type)
+	(else
+	 (error "unknown type name ~S" spec))))
+
+;--------------------------------------------------
+
+(define (display-type type port)
+
+  (define (do-list list)
+    (write-char #\( port)
+    (cond ((not (null? list))
+	   (do-type (car list))
+	   (for-each (lambda (type)
+		       (write-char #\space port)
+		       (do-type type))
+		     (cdr list))))
+    (write-char #\) port))
+
+  (define (do-type type)
+    (let ((type (maybe-follow-uvar type)))
+      (cond ((base-type? type)
+	     (display (base-type-name type) port))
+	    ((record-type? type)
+	     (display (record-type-name type) port))
+	    ((arrow-type? type)
+	     (write-char #\( port)
+	     (do-list (arrow-type-args type))
+	     (display " -> " port)
+	     (do-type (arrow-type-result type))
+	     (write-char #\) port))
+	    ((pointer-type? type)
+	     (write-char #\* port)
+	     (do-type (pointer-type-to type)))
+	    ((uvar? type)
+	     (write-char #\T port)
+	     (display (uvar-id type) port))
+	    ((type-scheme? type)
+	     (display "(for-all " port)
+	     (do-list (type-scheme-free-uvars type))
+	     (display " " port)
+	     (do-type (type-scheme-type type))
+	     (display ")" port))
+	    ((tuple-type? type)
+	     (display "(tuple " port)
+	     (do-list (tuple-type-types type))
+	     (display ")" port))
+	    (else
+	     (bug "don't know how to display type ~S" type)))))
+    
+  (do-type type))
\ No newline at end of file
diff --git a/ps-compiler/prescheme/unused/Notes b/ps-compiler/prescheme/unused/Notes
new file mode 100644
index 0000000..c3c1a61
--- /dev/null
+++ b/ps-compiler/prescheme/unused/Notes
@@ -0,0 +1,46 @@
+
+Need to check for multiple (effectively) identical closures.
+node-equal?
+
+Flatten needs to do something about shared strings and byte-vectors.
+
+Do SET! globals need to be treated differently?  Will C allow the following?
+ int f( int x ) { ... }
+ main() { f = ... }
+
+Check what happens if a name->enumerand or enumerand->name survives loading.
+
+CALL-WITH-VALUES needs to simplify to two calls (so that the known-call
+stuff works) even when it doesn't know what the type is (because of
+polymorphism; we don't resimplify when types change).
+ (call-with-values cont a b)
+   =>
+ (unknown-call (lambda (res:tuple)
+                 (unknown-call cont 'tuple-args  b res))
+	       'tuple-result
+               a)
+Need tuple-args-goto as well.  The protocol stuff has to do the right thing.
+When the tuple type is determined RES has to change in both places.
+Actually, it can just expand into this.  The type stuff will work out.
+For now I am not going to allow polymorphic use of call-with-values.
+All of this is much like Scheme.
+
+Non-tail-recursive named-LETS appear to break things.
+
+CALL-WITH-VALUES and VALUES are only allowed in call position, and the
+second argument to CALL-WITH-VALUES must be a lambda form.
+
+STOB->NODE in form.scm needs to look for substobs.
+Or does flatten flatten non-shared structures?
+
+Pointer comparisons need to be done using unsigned longs.
+=> Pre-Scheme needs unsigned comparisons u=, u<, etc.
+
+Primitives do not appear to check the argument count!
+
+Channel library may be doable as externals, including decoding
+the events.
+
+Tail-called forms that return multiple values?
+
+MAX and other primitives need to check number-of-args when type checking.
diff --git a/ps-compiler/prescheme/unused/assert.scm b/ps-compiler/prescheme/unused/assert.scm
new file mode 100644
index 0000000..90bb546
--- /dev/null
+++ b/ps-compiler/prescheme/unused/assert.scm
@@ -0,0 +1,152 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+; Inferencer needs to recognize predicates as such.
+; Also accessors if we want to get pattern matching working properly.
+; So we make a (predicate <record>) type.
+;
+; The inferencer needs to come up with true and false assertions for
+; each expression.  Assertion is either bottom or a list of
+; (<predicate> <exp> <#t-or-#f>) indicating predicates that are true
+; or false for that value of the expression.
+;
+; No.  For each expression we know its type, so we know exactly what
+; variants are possible.  All we need to keep track of is (<exp> <variants>).
+; The variants can be encoded as a bitset.
+
+; #t -> ()
+;       #f
+; #f -> #f
+;       ()
+; (<predicate> <exp>) -> ((<predicate> <exp> #t))
+;                        ((<predicate> <exp> #f))
+; (IF <test> <cons> <alt>) -> (or (and <test>t <cons>t)
+;                                 (and <test>f <alt>t))
+;                             (or (and <test>t <cons>f)
+;                                 (and <test>f <alt>f))
+;      (and #f S) -> #f
+;      (and S1 S2) -> (union S1 S2)
+;      (and ((e set1)) ((e set2))) -> #f if set3 = 0
+;                                     ((e set3)) otherwise
+;                                     where set3 = (bitwise-and set1 set2)
+;      (or S1 S2) -> (intersection S1 S2)
+;      (or ((e set1)) ((e set2))) -> ((e (bitwise-ior set1 set2)))
+;
+; (begin ... <last>) -> <last>t
+;                       <last>f
+; similarly for LETREC etc.
+;
+; NOT won't be inlined yet, so it will have to be known to the inferencer.
+; The usual OR macro won't work either, because the LET won't be understood.
+; That too will have to be primitive, and thus primitive in the interpreter
+; as well.  AND should work find as-is.
+;
+; NOT and OR can be ignored for the moment.
+;
+; (IF <test> <cons> <alt>) asserts <test>t values while checking <cons>
+; and <test>f while checking <alt>.
+;
+; There are so few rules that there is no need to have two separate
+; sets of inference rules.  Just have an entry point that drops the
+; assertions for those places that don't care.
+;
+; As a first cut the expressions in assertions can only be variables.
+; Also, since the assertions are type assertions, an assertion list can
+; have only one true assertion for any given expression.
+
+(define-record-type assertion
+  (value    ; variable (or, later, slot) whose value is being asserted
+   type     ; the union type we are making assertions about
+   variants ; bitset of allowable variants
+   ; slots  ; for assertions about particular slots, should we ever get that far
+   )
+  ())
+
+(define make-assertion assertion-maker)
+
+(define (copy-assertion assert new-variants)
+  (assertion-maker (assertion-value assert)
+		   (assertion-type assert)
+		   new-variants))
+
+; To make merging simpler, assertion lists are sorted by variable-id.
+
+; Union of two assertion lists.
+
+(define (assertion-and l1 l2)
+  (if (and l1 l2)
+      (real-assertion-and l1 l2)
+      #f))
+
+(define (real-assertion-and l1 l2)
+  (let loop ((l1 l1) (l2 l2) (res '()))
+    (cond ((null? l1)
+	   (append (reverse res) l2))
+	  ((null? l2)
+	   (append (reverse res) l1))
+	  (else
+	   (let ((i1 (variable-id (assertion-value (car l1))))
+		 (i2 (variable-id (assertion-value (car l2)))))
+	     (cond ((< i1 i2)
+		    (loop (cdr l1) l2 (cons (car l1) res)))
+		   ((< i2 i1)
+		    (loop l1 (cdr l2) (cons (car l2) res)))
+		   (else
+		    (let ((variants (set-and (assertion-variants (car l1))
+					     (assertion-variants (car l2)))))
+		      (if (null-set? variants)
+			  #f
+			  (loop (cdr l1)
+				(cdr l2)
+				(cons (copy-assertion (car l1) variants)
+				      res)))))))))))
+
+; Intersection of two assertion lists.
+
+(define (assertion-or l1 l2)
+  (if l1
+      (if l2
+	  (real-assertion-or l1 l2)
+	  l1)
+      #f))
+
+(define (real-assertion-or l1 l2)
+  (let loop ((l1 l1) (l2 l2) (res '()))
+    (if (or (null? l1)
+	    (null? l2))
+	(reverse res)
+	(let ((i1 (variable-id (assertion-value (car l1))))
+	      (i2 (variable-id (assertion-value (car l2)))))
+	  (cond ((< i1 i2)
+		 (loop (cdr l1) l2 res))
+		((< i2 i1)
+		 (loop l1 (cdr l2) res))
+		(else
+		 (loop (cdr l1)
+		       (cdr l2)
+		       (let ((variants (set-ior (assertion-variants (car l1))
+						(assertion-variants (car l2)))))
+			 (if (set-eq? variants
+				      (full-variant-set (assertion-type (car l1))))
+			     (cons (copy-assertion (car l1) variants)
+				   res)
+			     res)))))))))
+
+;----------------
+; Use shallow binding to install the types provided by ASSERTIONS while
+; THUNK is evaluated.
+
+(define (with-assertions assertions thunk)
+  (let ((old-types (map install-assertion! assertions)))
+    (thunk)
+    (for-each (lambda (assert type)
+		(set-variable-type! (assertion-value assert) type))
+	      assertions
+	      old-types)))
+
+(define (install-assertion! assert)
+  (let ((type (variable-type (assertion-value assert))))
+    (set-variable-type! (assertion-value assert)
+			(get-union-subtype (assertion-type assert)
+					   (assertion-variants assert)))
+    type))
diff --git a/ps-compiler/prescheme/unused/cps-to-scheme.scm b/ps-compiler/prescheme/unused/cps-to-scheme.scm
new file mode 100644
index 0000000..f757f5f
--- /dev/null
+++ b/ps-compiler/prescheme/unused/cps-to-scheme.scm
@@ -0,0 +1,340 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+; Printing the node tree as Scheme code
+
+; Sample output:
+
+;  (LAMBDA (C_11 UNIT_0)
+;    (SET-CONTENTS 1 C_11 UNIT_0 UNIT '0
+;      (LAMBDA (C_13 N_1)
+;        (LET ((LOOP_73 (CONS CELL '0)))
+;          (SET-CONTENTS LOOP_73 CELL '0
+;            (LAMBDA (C_33 I_9 R_7)
+;              (LET* ((V_61 (CONTENTS UNIT_0 UNIT '3))
+;                     (V_63 (V_61 I_9 '0)))
+;                (IF (TRUE? V_63)
+;                    (C_33 0 R_7)
+;                    (LET* ((V_46 (CONTENTS UNIT_0 UNIT '2))
+;                           (V_56 (V_46 I_9 R_7))
+;                           (V_44 (CONTENTS UNIT_0 UNIT '1))
+;                           (V_54 (V_44 I_9 '1))
+;                           (V_52 (CONTENTS LOOP_73 CELL '0)))
+;                      (V_52 1 C_33 V_54 V_56))))))
+;          (LET ((V_77 (CONTENTS LOOP_73 CELL '0)))
+;            (V_77 1 C_13 N_1 '1))))))
+
+; (CPS->SCHEME node port)
+;---------------------------------------------------------------------------
+; Print CPS node tree in linear form.  This just dispatches on the type of NODE.
+
+(define (cps->scheme node port)
+  (set! *next-pp-id* 0)
+  (let* ((port (if (current-column port)
+		   port
+		   (make-tracking-output-port port))))
+    (cond ((lambda-node? node)
+           (pp-cps-lambda node 4 port))
+          ((call-node? node)
+           (write-non-simple-call node port))
+          (else
+           (write-node-value node port)))
+    (newline port)))
+
+(define (indent port count)
+  (let ((count (cond ((<= (current-column port) count)
+		      (- count (current-column port)))
+		     (else
+		      (newline port)
+		      count))))
+    (do ((count count (- count 1)))
+	((>= 0 count))
+      (writec port #\space))))
+		      
+(define *next-pp-id* 0)
+
+(define (next-pp-id)
+  (let ((id *next-pp-id*))
+    (set! *next-pp-id* (+ *next-pp-id* 1))
+    id))
+
+; Print a lambda node by printing its identifiers, then its call, and finally
+; any other lambdas that it includes.
+
+(define (pp-cps-lambda node indent-to port)
+  (format port "~&~%")
+  (indent port indent-to)
+  (display "(lambda " port)
+  (write-lambda-vars node port)
+  (pp-cps-body (lambda-body node) indent-to port)
+  (writec port #\)))
+
+(define (write-lambda-vars node port)
+  (let ((vars (if (proc-lambda? node)
+		  (cdr (lambda-variables node))  ; ignore cont var
+		  (lambda-variables node))))
+    (cond ((not (null? vars))
+           (writec port '#\()
+           (print-variable-name (car vars) port)
+           (do ((v (cdr vars) (cdr v)))
+               ((null? v))
+             (writec port '#\space)
+             (print-variable-name (car v) port))
+           (writec port '#\)))
+          (else
+           (format port "()")))))
+
+; Print the body of a lambda node.  A simple call is one that has exactly
+; one exit.  They and calls to lambda nodes are printed as a LET*.
+
+(define (pp-cps-body call indent-to port)
+  (newline port)
+  (indent indent-to port)
+  (cond ((table-ref primop-print-table (primop-id (call-primop call)))
+	 => (lambda (proc)
+	      (proc call indent-to port)))
+	((not (= 1 (call-exits call)))
+	 (bug "no printer for primop in ~S" call))
+	(else
+	 (let* ((cont (call-arg call 0))
+		(cont-vars (lambda-variables cont)))
+	   (cond ((every? unused? cont-vars)
+		  (print-call call 1 port)
+		  (pp-cps-body (lambda-body (call-arg call 0))))
+		 ((null? (cdr cont-vars))
+		  (display "(let ((" port)
+		  (print-variable-name (car cont-vars))
+		  (display " " port)
+		  (print-call call 1 port)
+		  (display "))" port)
+		  (pp-cps-body call (+ indent-to 2) port))
+		 (else
+		  (display "(receive " port)
+		  (write-lambda-vars cont port)
+		  (newline port)
+		  (indent (+ indent-to 4) port)
+		  (print-call call 1 port)
+		  (pp-cps-body call (+ indent-to 2) port)))))))
+		  
+(define (print-call call start-arg port)
+  (display "(" port)
+  (display (primop-id (call-primop call)) port)
+  (print-args call start-arg port)
+  (display ")" port))
+	 
+(define (print-args call start-arg port)
+  (do ((i start-arg (+ i 1)))
+      ((= i (call-arg-count call)))
+    (display " " port)
+    (print-arg (call-arg call i) port)))
+
+(define (print-arg arg port)
+  (cond ((lambda-node? node)
+	 
+	((call-node? node)
+	 (format port "(~S" (primop-id (call-primop node)))
+	 (print-args node 0 port))
+        ((literal-node? node)
+         (cps-print-literal (literal-value node) port))
+        ((reference-node? node)
+         (print-variable-name (reference-variable node) port))
+        (else
+         (bug "WRITE-NODE-VALUE got funny node ~S" node))))
+
+
+
+  (cond ((or (simple-call? call)
+             (let-call? call))
+         (write-let* call indent-to port))
+        (else
+         (indent port (+ '2 indent-to))
+         (write-non-simple-call call port))))
+
+; Write out a series of calls as a LET*.  The LET* ends when a call is reached
+; that is neither a simple call or a call to a lambda.
+
+(define (write-let* call indent-to port)
+  (indent port (+ '2 indent-to))
+  (writec port '#\()
+  (format port "LET* ")
+  (writec port '#\()
+  (let loop ((call (next-call call))
+	     (ns (write-simple-call call indent-to port)))
+    (cond ((or (simple-call? call)
+               (let-call? call))
+           (newline port)
+           (indent port (+ '9 indent-to))
+           (loop (next-call call)
+                 (append (write-simple-call call indent-to port) ns)))
+          (else
+           (writec port '#\))
+           (newline port)
+           (indent port (+ '4 indent-to))
+           (let ((ns (append (write-non-simple-call call port) ns)))
+             (writec port '#\))
+             ns)))))
+
+(define (simple-call? call)
+  (and (= '1 (call-exits call))
+       (not (lambda-block (call-arg call 0)))))
+
+(define (let-call? call)
+  (calls-this-primop? call 'let))
+
+; Get the call that follows CALL in a LET*.
+
+(define (next-call call)
+  (lambda-body (call-arg call '0)))
+
+; Write out one line of a LET*.
+
+(define (write-simple-call call indent-to port)
+  (if (let-call? call)
+      (write-let-call call indent-to port)
+      (really-write-simple-call call indent-to port)))
+
+; Write the variables bound by the continuation and then the primop and
+; non-continuation arguments of the call.
+
+(define (really-write-simple-call call indent-to port)
+  (writec port '#\()
+  (write-lambda-vars (call-arg call '0) port)
+  (indent port (+ indent-to '21))
+  (writec port '#\()
+  (format port "~S" (primop-id (call-primop call)))
+  (write-call-args call '1 port)
+  (writec port '#\))
+  (find-lambda-nodes call 1))
+
+; Write the variables of the lambda and then the values of the arguments.
+
+(define (write-let-call call indent-to port)
+  (writec port '#\()
+  (write-lambda-vars (call-arg call '0) port)
+  (cond ((= '1 (vector-length (call-args call)))
+         (writec port '#\))
+         '())
+        (else
+	 (writec port #\*)
+         (indent port (+ indent-to '21))
+         (write-node-value (call-arg call '1) port)
+         (write-call-args call '2 port)
+	 (find-lambda-nodes call 1))))
+
+(define (find-lambda-nodes call start)
+  (reverse (let label ((call call) (start start) (ls '()))
+	     (do ((i start (+ i 1))
+		  (ls ls (let ((arg (call-arg call i)))
+			   (cond ((call-node? arg)
+				  (label arg 0 ls))
+				 ((lambda-node? arg)
+				  (cons arg ls))
+				 (else ls)))))
+		 ((>= i (call-arg-count call))
+		  ls)))))
+
+; Write out a call that ends a LET* block.
+
+(define (write-non-simple-call call port)
+  (writec port '#\()
+  (format port "~A ~D" (primop-id (call-primop call)) (call-exits call))
+  (write-call-args call '0 port)
+  (find-lambda-nodes call 0))
+
+; Write out the arguments of CALL starting with START.
+
+(define (write-call-args call start port)
+  (let* ((vec (call-args call))
+         (len (vector-length vec)))
+    (do ((i start (+ i '1)))
+        ((>= i len))
+      (writec port '#\space)
+      (write-node-value (vector-ref vec i) port))
+    (writec port '#\))))
+
+; Print out a literal value.
+
+(define (cps-print-literal value port)
+  (format port "'~S" value))
+
+; Dispatch on the type of NODE to get the appropriate printing method.
+
+(define (write-node-value node port)
+  (cond ((not (node? node))
+         (format port "{not a node}"))
+        ((lambda-node? node)
+         (writec port '#\^)
+         (print-lambda-name node port))
+	((call-node? node)
+	 (format port "(~S" (primop-id (call-primop node)))
+	 (write-call-args node '0 port))
+        ((literal-node? node)
+         (cps-print-literal (literal-value node) port))
+        ((reference-node? node)
+         (print-variable-name (reference-variable node) port))
+        (else
+         (bug "WRITE-NODE-VALUE got funny node ~S" node))))
+
+; Printing variables and lambda nodes
+
+; #T if variables are supposed to print as the name of the register containing
+; them instead of their name.
+
+(define *pp-register-names?* '#f)
+
+; A whole bunch of different entry points for printing variables in slightly
+; different ways.
+
+(define (print-variable-name var port)
+  (cond ((not var)
+         (format port "#f"))
+;        ((and *pp-register-names?*
+;              (reg? (variable-register var)))
+;         (format port "~S" (reg-name (variable-register var))))
+        (else
+	 (let ((id (cond ((variable-flag var)
+			  => identity)
+			 (else
+			  (let ((id (next-pp-id)))
+			    (set-variable-flag! var id)
+			    id)))))
+	   (format port "~S_~S" (variable-name var) id)))))
+
+; Same as the above without the check for a register.
+
+(define (print-variable-plain-name var port)
+  (cond ((not var)
+         (format port "#f"))
+        (else
+         (format port "~S_~D" (variable-name var) (variable-id var)))))
+
+; Return the name as a string.
+
+(define (variable-print-name var)
+  (print-variable-name var '#f))
+
+; Return the name as a symbol.
+
+(define (variable-unique-name var)
+  (string->symbol (variable-print-name var)))
+
+; Printing lambda-nodes as variables
+
+(define (print-lambda-name lnode port)
+  (let ((id (cond ((node-flag lnode)
+		   => identity)
+		  (else
+		   (let ((id (next-pp-id)))
+		     (set-node-flag! lnode id)
+		     id)))))
+    (format port "~S_~D" (lambda-name lnode) id)))
+
+(define (lambda-print-name lnode)
+  (print-lambda-name lnode '#f))
+
+(define (lambda-unique-name lnode)
+  (string->symbol (lambda-print-name lnode)))
+
+
+
+
+
diff --git a/ps-compiler/prescheme/unused/data.scm b/ps-compiler/prescheme/unused/data.scm
new file mode 100644
index 0000000..dc36f01
--- /dev/null
+++ b/ps-compiler/prescheme/unused/data.scm
@@ -0,0 +1,193 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+; Records & (tagged) Unions
+;
+; Can we arrange to pass records as a separate type from the including union?
+; Probably not.  This introduces type relations that have to be satisified.
+; No coercions are needed so it would be much simpler than before.  Unification
+; would have to find meets.  I guess that it would be doable, but not for now.
+;
+; The only records that have tags are those that are part of a multi-record
+; union.  If a record is not part of a union it does not need a tag field.
+;
+; The simplest thing is probably to only have tagged unions, with stand-alone
+; records being a degenerate case (to be added later).
+
+; Data types
+
+; Representation of union types.
+
+(define-record-type union-type
+  (name       ; name of the data type
+   variants   ; what this can be
+   )
+  ())
+
+(define-record-discloser type/union-type
+  (lambda (union)
+    (list 'union-type (union-type-name dtype))))
+
+; Record variants of unions
+
+(define-record-type record-type
+  (index                ; index of this record in parent union
+   predicate            ; name of the predicate   ; only at top-level
+   constructor          ; name of the constructor
+   )
+  (fields               ; filled in later because of circularity
+   constructor-args))   ; fields passed to the constructor 
+
+(define-record-discloser type/record-type
+  (lambda (rtype)
+    (list 'record-type (record-type-constructor rtype))))
+
+; Fields of record types.
+
+(define-record-type record-field
+  (record-type
+   name
+   type
+   )
+  ())
+
+; Global table of record types.  Since we compile to a single C file the
+; record types used within a single computation must have distinct names.
+; (This should really be a fluid.)
+; Or we could make up names as necessary.
+
+(define *record-type-table* (make-symbol-table))
+
+(define (reset-record-data!)
+  (set! *record-type-table* (make-symbol-table)))
+
+(define (get-record-type id)
+  (cond ((table-ref *record-type-table* id)
+	 => identity)
+	(else
+	 (error "no record type ~S" id))))
+
+(define (all-record-types)
+  (table->entry-list *record-type-table*))
+
+(define (lookup-union-type id)
+  (table-ref *record-type-table* id))
+
+; Construction a record type.  This gets the name, the list of fields whose
+; initial values are passed to the constructor, and the field specifications.
+; Each field specification consists of a name and a type.
+
+(define (make-record-type id constructor-args specs)
+  (let ((rt (record-type-maker id)))
+    (if (table-ref *record-type-table* id)
+	(user-error "multiple definitions of record type ~S" id))
+    (table-set! *record-type-table* id rt)
+    (set-record-type-fields! rt (map (lambda (spec)
+				       (record-field-maker
+					  rt
+					  (car spec)
+					  (expand-type-spec (cadr spec))))
+				     specs))
+    (set-record-type-constructor-args! rt
+				       (map (lambda (name)
+					      (get-record-type-field id name))
+					    constructor-args))
+    rt))
+
+; Return the field record for FIELD-ID in record-type TYPE-ID.
+
+(define (get-record-type-field type-id field-id)
+  (let ((rtype (get-record-type type-id)))
+    (cond ((any (lambda (field)
+		  (eq? field-id (record-field-name field)))
+		(record-type-fields rtype))
+	   => identity)
+	  (else
+	   (user-error "~S is not a field of ~S" field-id rtype)))))
+
+; The macro expander for DEFINE-RECORD-TYPE.
+;
+; (define-record-type <id> <type-id>
+;   (<constructor> . <field-names>)
+;   (<field-name> <type> <accessor-name> [<modifier-name>]) ...)
+; 
+; The <type-id> is used only by Pre-Scheme-in-Scheme.
+
+(define (expand-define-record-type exp r c)
+  (let ((id (cadr exp))
+	(maker (cadddr exp))
+	(fields (cddddr exp)))
+    (let ((rt (make-record-type id (cdr maker) fields)))
+      `(,(r 'begin)
+	(,(r 'define) ,maker
+	   (,(r 'let) ((,(r id) (,(r 'make-record) ',id)))
+	     (,(r 'if) (,(r 'not) (,(r 'null-pointer?) ,(r id)))
+	       (,(r 'begin)
+		 . ,(map (lambda (name)
+			   `(,(r 'record-set!) ,(r id) ,name ',id ',name))
+			 (cdr maker))))
+	     ,(r id)))
+	,@(map (lambda (field)
+		 `(,(r 'define) (,(caddr field) ,(r id))
+				(,(r 'record-ref) ,(r id) ',id ',(car field))))
+	       fields)
+	,@(map (lambda (field)
+		 `(,(r 'define) (,(cadddr field) ,(r id) ,(r 'x))
+			(,(r 'record-set!)
+			 ,(r id) ,(r 'x)',id ',(car field))))
+	       (filter (lambda (spec)
+			 (not (null? (cdddr spec))))
+		       fields))))))
+
+
+; In C.
+;
+; All unions are cast to a single type.  All records that are part of unions
+; have an initial tag field.
+;
+;struct datatypeX { int tagX; };
+;
+;#define NULL_TAGX 0
+;#define PAIR_TAGX 1
+;
+;struct pair {
+;  int tagX;
+;  long car;
+;  struct datatypeX *cdr;
+;};
+;
+;struct datatypeX nullX = { NULL_TAGX }, *null = &nullX;
+;
+;struct datatypeX *cons(unsigned char, struct datatypeX*);
+;struct datatypeX *reverseB(struct datatypeX*);
+;char memberP(struct datatypeX*, long);
+;void init(void);
+;
+;struct datatypeX *cons(unsigned char car_0X, struct datatypeX *cdr_1X)
+;{
+;  struct pair *pair_2X;
+; {pair_2X = (struct pair *)malloc(sizeof(struct pair));
+;  if ((NULL == pair_2X)) {
+;    return (struct datatypeX *)pair_2X;}
+;  else {
+;    pair_2X->tagX = PAIR_TAGX;
+;    pair_2X->car = (((unsigned long) car_0X));
+;    pair_2X->cdr = cdr_1X;
+;    return (struct datatypeX *)pair_2X;}}}
+;
+;char memberP(struct datatypeX *list_7X, long x_8X)
+;{
+;  struct datatypeX *arg0K0;
+;  struct datatypeX *list_9X;
+; {arg0K0 = list_7X;
+;  goto L169;}
+; L169: {
+;  list_9X = arg0K0;
+;  if ((list_9X->tagX == NULL_TAGX)) {
+;    return 0;}
+;  else {
+;    if ((x_8X == ((struct pair *)list_9X)->car)) {
+;      return 1;}
+;    else {
+;      arg0K0 = ((struct pair *)list_9X)->cdr;
+;      goto L169;}}}}
diff --git a/ps-compiler/prescheme/unused/data.txt b/ps-compiler/prescheme/unused/data.txt
new file mode 100644
index 0000000..413c078
--- /dev/null
+++ b/ps-compiler/prescheme/unused/data.txt
@@ -0,0 +1,73 @@
+
+(define-data-type list
+  (null? null)
+  (pair?
+   (cons car cdr)
+   (car type car set-car!)
+   (cdr pair cdr set-cdr!)))
+
+=>
+
+(define null 0)
+cons etc. as before
+
+Type as before, except that LIST is defined to be a datatype
+that includes NULL and PAIRs.  NULL and PAIRs are defined to
+be subtypes of LISTs.  How do pairs and null get injected into
+lists?
+
+What about polymorphism?  Ignore it for now.
+
+Note that setters have a problem with destructuring - they don't work.
+
+(if (bar? baz)
+    ...
+    ...)
+
+Need temporary type bindings, a la LET.  Env and type env?
+Have to do shallow binding, the infer code doesn't use environments.
+
+Hacks like
+
+   (if (bar? baz)
+       (error ...))
+   ... baz is not a bar ...
+
+won't work.
+
+----------------
+
+New plan.  Use functions for pattern matching, with a suitable macro.
+
+(define-data-type list delistify match-list
+  (null? null)
+  (pair?
+   (cons car cdr)
+   (car type car set-car!)
+   (cdr pair cdr set-cdr!)))
+
+Defines null as 0 and pairs as before.
+NULL? and PAIR? are only available at load time.  There is also a
+deconstructor DELISTIFY: [b list, [] -> a , [b, b list] -> a] -> a
+
+(define (map f l)
+  (delistify l
+    (lambda ()
+      null)
+    (lambda (car cdr)
+      (cons (f car) (map f cdr)))))
+
+Or, with syntax,
+
+(define (map f l)
+  (match-list l
+    ((null)
+     null)
+    ((cons car cdr)
+     (cons (f car) (map f cdr)))))
+
+This requires no change at all for the type checker.  Hee Wack!
+
+
+
+
diff --git a/ps-compiler/prescheme/unused/dispatch.scm b/ps-compiler/prescheme/unused/dispatch.scm
new file mode 100644
index 0000000..49a1da4
--- /dev/null
+++ b/ps-compiler/prescheme/unused/dispatch.scm
@@ -0,0 +1,169 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define (dispatches->computed-gotos forms)
+  (walk (lambda (f)
+	  (if (and (form-var f)
+		   (eq? 'initialize (form-type f)))
+	      (let ((value (thunk-value (form-node f))))
+		(if (and value
+			 (call-node? value)
+			 (eq? 'make-dispatch-table
+			      (primop-id (call-primop value))))
+		    (dispatch->computed-goto f value)))))
+	forms)
+  forms)
+
+; FORM defines a dispatch vector, created in MAKE-CALL.  This replaces the
+; dispatch vector with a procedure that performs a computed goto.
+; The references to VAR, the variable to which the dispatch
+; vector is bound, are analysed to find all of the uses of the vector and all
+; of the dispatch procedures added to it.  These procedures are put in the
+; appropriate slot of VEC, a model of the dispatch vector.
+;   Once all of the references are known, the dispatch vector is replaced with
+; a procedure and all of the dispatches are replaced with calls.  The dispatch
+; procedures from VEC become the continuations of the computed-goto call.
+
+(define (dispatch->computed-goto form make-call)
+  (initialize-lambdas)
+  (let* ((var (form-var form))
+	 (size-node (call-arg make-call 0))
+	 (size (if (and (literal-node? size-node)
+			(integer? (literal-value size-node))
+			(>= (literal-value size-node) 0))
+		   (literal-value size-node)
+		   (error "dispatch vector ~A's size is not a positive integer"
+			  (variable-name (form-var form)))))
+	 (vec (make-vector size #f)))
+    (analyze-dispatch-vector var vec)
+    (add-lambdas (form-lambdas form))
+    (let ((goto-proc (make-computed-goto var vec size make-call)))
+      (for-each (lambda (ref)
+		  (let ((call (node-parent ref)))
+		    (set-call-primop! call (get-primop (enum primop unknown-call)))
+		    (insert-call-arg call 2 (make-literal-node 1 #f))))
+		(variable-refs var))
+      (set-form-node! form goto-proc (make-lambda-list))
+      (set-form-type! form 'lambda)
+      (values)))))
+
+; Possible problems with a call to DEFINE-DISPATCH are:
+; The index is not an integer constant in the right range.
+; The procedure value cannot be moved.
+
+(define (analyze-dispatch-vector var vec)
+  (walk-refs-safely
+   (lambda (ref)
+     (let ((call (node-parent ref)))
+       (if (and (eq? 'define-dispatch! (primop-id (call-primop call)))
+		(= 1 (node-index ref)))
+	   (let ((index (if (literal-node? (call-arg call 2))
+			    (literal-value (call-arg call 2))
+			    #f))
+		 (proc (get-procedure-value (call-arg call 3)))
+		 (form (node-flag (node-base ref))))
+	     (if (or (not (integer? index))
+		     (< index 0)
+		     (>= index (vector-length vec))
+		     (not proc))
+		 (error "problem with DEFINE-DISPATCH! in ~S"
+			(form-source form)))
+	     (receive (ours theirs)
+		 (partition-list (lambda (n)
+				   (eq? proc (node-base n)))
+				 (form-lambdas form))
+	       (replace-body call (detach-body (lambda-body (call-arg call 0))))
+	       (set-form-lambdas! form theirs)
+	       (add-lambdas ours)
+	       (vector-set! vec index proc))))))
+   var))
+
+(define (get-procedure-value node)
+  (cond ((lambda-node? node)
+	 (if (no-free-references? node)
+	     (detach node)
+	     #f))
+	((global-reference? node)
+	 (detach node))
+	(else #f)))
+
+; make computed goto call, put the exits in the call
+
+(define (make-computed-goto var vec size make-call)
+  (receive (goto-proc goto-call default-var cont-var)
+           (make-dispatch-procedure make-call size)
+    (do ((i 0 (+ i 1)))
+	((>= i size))
+      (let ((cont (if (vector-ref vec i)
+		      (make-goto-continuation (vector-ref vec i) cont-var)
+		      (make-goto-default default-var))))
+	(attach goto-call i cont)))
+    (simplify-lambda-body goto-proc)
+    goto-proc))
+
+; ($MAKE-DISPATCH-TABLE <cont> <size> <default>)
+;   =>
+; (LAMBDA (C I)
+;   ((LAMBDA (D)
+;      ($COMPUTED-GOTO <empty> ... <empty> I))
+;    (LAMBDA ()
+;      (LET ((X ($PROC-CALL <default>)))
+;        ($UNKNOWN-RETURN C X)))))
+;
+; The new procedure, the goto call, D, the default procedure, and C are all
+; returned.
+
+(define (make-dispatch-procedure call size)
+  (let ((default (detach (call-arg call 1)))
+	(goto-call (make-call-node (get-prescheme-primop 'computed-goto)
+				   (+ size 1)
+				   size)))
+    (if (not default)
+	(error '"cannot move dispatch default ~S" (call-arg call 1)))
+    (let-nodes ((l1 ((c type/unknown) (i type/unknown)) (let 1 l2 def))
+		(l2 ((d type/unknown)) goto-call)
+		(def () (unknown-call 1 l3 default '(0 #f)))
+		(l3 ((x type/unknown)) (unknown-return 0 (* c) '1 (* x))))
+      (attach goto-call size (make-reference-node i))
+      (change-lambda-type l1 'proc)  ; LET-NODES only makes CONT lambdas
+      (set-lambda-protocol! l1 1) ; indicate number of non-cont arguments
+      (erase (node-base call))
+      (values l1 goto-call d c))))
+
+; Return a continuation that calls DEFAULT-PROC (to which DEFAULT-VAR is bound).
+
+(define (make-goto-default default-var)
+  (let-nodes ((l1 () (jump 0 (* default-var))))
+    l1))
+
+; Make a continuation that calls PROC and then returns to CONT-VAR.
+;
+;  (LAMBDA ()
+;    (CALL (LAMBDA (V) (UNKNOWN-RETURN <cont-var> V))
+;          <proc>))
+
+(define (make-goto-continuation proc-node cont-var)
+  (let-nodes ((l1 () c1)
+	      (c1 (unknown-call 1 l2 proc-node '(0 #f)))
+	      (l2 ((v type/unknown))
+		  (unknown-return 0 (* cont-var) '1 (* v))))
+    l1))
+
+;------------------------------------------------------------------------------
+; Defining the primops used in all this.
+
+; (MAKE-DISPATCH-TABLE <size> <default>)
+
+(define-scheme-primop make-dispatch-table allocate)
+
+; ($DEFINE-DISPATCH! <table> <index> <procedure>)
+
+(define-nonsimple-scheme-primop define-dispatch! write)
+
+; ($DISPATCH <cont> <table>)
+
+(define-nonsimple-scheme-primop dispatch)
+
+; (COMPUTED-GOTO <exit0> <exit1> ... <exitN> <dispatch-value>)
+
+(define-nonsimple-scheme-primop computed-goto)
diff --git a/ps-compiler/prescheme/unused/infer-data.scm b/ps-compiler/prescheme/unused/infer-data.scm
new file mode 100644
index 0000000..f6649e5
--- /dev/null
+++ b/ps-compiler/prescheme/unused/infer-data.scm
@@ -0,0 +1,381 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+; Type checking nodes.
+
+; Hacked to propogate data-type information.
+
+; Entry point
+
+; Because NODE is not the car of a pair, this depends on lambdas not being
+; coerceable and literal nodes being coerced in place (instead of having a
+; call inserted).
+
+(define (infer-definition-type node name)
+  (set! *currently-checking* name)
+  (let ((res (cond ((literal-node? node)
+		    (infer-literal-type node name))
+		   ((lambda-node? node)
+		    (infer-type node 0))
+		   ((name-node? node)
+		    (get-global-type (binding-place (node-ref node 'binding))))
+		   (else
+		    (bug "definition value is not a value node ~S" node)))))
+    (set! *currently-checking* #f)
+    res))
+
+(define (infer-literal-type node name)
+  (let ((value (node-form node)))
+    (cond ((vector? value)
+	   (let ((uvar (make-uvar name -1)))
+	     (do ((i 0 (+ i 1)))
+		 ((>= i (vector-length value)))
+	       (unify! uvar (type-check-thing (vector-ref value i)) value))
+	     (make-pointer-type (maybe-follow-uvar uvar))))
+	  (else
+	   (infer-type node 0)))))
+
+(define (type-check-thing thing)
+  (if (variable? thing)
+      (get-package-variable-type thing)
+      (literal-value-type thing)))
+
+(define literal-operator (get-operator 'literal))
+
+(define (make-literal-node value)
+  (make-node literal-operator value))
+
+; Get the type of the variable - if it is a type-variable, then create a new
+; one and relate the two; if it is a polymorphic pattern, instantiate it.
+
+(define (get-package-variable-type var)
+  (let ((rep (variable-type var)))
+    (cond ((eq? rep type/undetermined)
+	   (let ((type (make-uvar (variable-name var) -1)))
+	     (set-variable-type! var type)
+	     (set-uvar-source! type var)
+	     type))
+	  ((type-scheme? rep)
+	   (instantiate-type-scheme rep -1))
+	  (else
+	   rep))))
+
+; Exported
+
+(define (get-variable-type var)
+  (let ((rep (variable-type var)))
+    (cond ((eq? rep type/undetermined)
+	   (bug "lexically bound variable ~S has no type" var))
+	  ((type-scheme? rep)
+	   (instantiate-type-scheme rep -1))
+	  (else
+	   rep))))
+
+;----------------------------------------------------------------
+
+(define (infer-type node depth)
+  (receive (type true false)
+      (infer-tail-type node depth #f)
+    type))
+
+; This returns both a type for the expression and two lists of type assertions
+; for variables.  Those in the first list apply if the expression evaluates to
+; true and those that apply if the predicate evaluates to false.  An assertion
+; has two parts: an expression E (which currently must be a variable) whose
+; type is a union, and the set of variants of that union which the variable
+; might have.  If NODE cannot have a particular boolean value the corresponding
+; list of assertions is #F.
+
+; RETURN? is true if NODE is syntactically tail-recursive in some procedure
+; or a non-final expression in a body, in which case NODE is allowed to have
+; a tuple type.
+
+(define (infer-tail-type node depth return?)
+  (receive (type true false)
+      ((operator-table-ref inference-rules (node-operator-id node))
+         node
+	 depth
+	 return?)
+    (set-node-type! node type)
+    (values (maybe-follow-uvar type) true false)))
+
+; Return a true value: no true assertions and value is never false.
+
+(define (true-value value)
+  (values value '() #f))
+
+(define (unknown-value value)
+  (values value '() '()))
+
+(define inference-rules
+  (make-operator-table
+   (lambda (node depth return?)
+     (error "no type inference for node ~S" node))))
+
+(define (define-inference-rule name proc)
+  (operator-define! inference-rules name #f proc))
+
+(define-inference-rule 'literal
+  (lambda (node depth return?)
+    (infer-literal (node-form node) node)))
+
+(define-inference-rule 'quote
+  (lambda (node depth return?)
+    (infer-literal (cadr (node-form node)) node)))
+
+(define (infer-literal value node)
+  (literal-value-type value))
+
+(define (literal-value-type value)
+  (if value
+      (true-value (or (maybe-literal-value-type value)
+		      (error "don't know type of literal ~S" value)))
+      (values type/boolean #f '())))  ; always false, but no actual assertions
+
+(define (maybe-literal-value-type value)
+  (cond ((boolean? value)
+	 type/boolean)
+	((char? value)
+	 type/char)
+	((integer? value)
+	 type/integer)
+	((string? value)
+	 type/string)
+	(((structure-ref eval-node unspecific?) value)
+	 type/null)
+	((input-port? value)
+	 type/input-port)
+	((output-port? value)
+	 type/output-port)
+	((external-value? value)
+	 (external-value-type value))
+	((external-constant? value)
+         type/integer)
+	(else
+	 #f)))
+
+(define-inference-rule 'unspecific
+  (lambda (node depth return?)
+    (unknown-value type/null)))
+
+(define-inference-rule 'lambda
+  (lambda (node depth return?)
+    (let* ((uid (unique-id))
+	   (exp (node-form node))
+	   (var-types (map (lambda (name-node)
+			     (initialize-name-node-type name-node uid depth))
+			   (cadr exp)))
+	   (result (infer-tail-type (caddr exp) depth #t)))
+      ; stash the return type
+      (set-lambda-node-return-type! node result)
+      (true-value (make-arrow-type var-types result)))))
+	
+; Create a new type variable for VAR.
+
+(define (initialize-name-node-type node uid depth)
+  (let ((uvar (make-uvar (node-form node) depth uid)))
+    (set-node-type! node uvar)
+    (set-uvar-source! uvar node)
+    uvar))
+
+; Get the type of the variable - if it is a type-variable, then create a new
+; one and relate the two; if it is a polymorphic pattern, instantiate it.
+; How to pass the source?
+
+(define-inference-rule 'name
+  (lambda (node depth return?)
+    (let ((type (if (node-ref node 'binding)
+		    (get-global-type (binding-place (node-ref node 'binding)))
+		    (node-type node))))
+      (if (not type)
+	  (bug "name node ~S has no type" node))
+      (if (type-scheme? type)
+	  (instantiate-type-scheme type depth)
+	  (unknown-value type)))))
+
+(define-inference-rule 'primitive
+  (lambda (node depth return?)
+    (let ((type (get-global-type (cdr (node-form node)))))
+      (true-value (if (type-scheme? type)
+		      (instantiate-type-scheme type depth)
+		      type)))))
+
+; If no type is present, create a type variable.
+
+(define (get-global-type value)
+  (if (location? value)
+      (literal-value-type (contents value))
+      (let ((has (maybe-follow-uvar (variable-type value))))
+	(cond ((not (eq? has type/undetermined))
+	       has)
+	      (else
+	       (let ((type (make-uvar (variable-name value) -1)))
+		 (set-variable-type! value type)
+		 (set-uvar-source! type value)
+		 type))))))
+
+(define-inference-rule 'set!
+  (lambda (node depth return?)
+    (let* ((exp (node-form node))
+	   (type (infer-type (caddr exp) depth))
+	   (binding (node-ref (cadr exp) 'binding)))
+      (if (not binding)
+	  (error "SET! on a local variable ~S" (schemify node)))
+      (unify! type (variable-type (binding-place binding)) node)
+      (unknown-value type/null))))
+
+(define-inference-rule 'call
+  (lambda (node depth return?)
+    (rule-for-calls (node-form node) node depth return?)))
+
+(define-inference-rule 'goto
+  (lambda (node depth return?)
+    (rule-for-calls (cdr (node-form node)) node depth return?)))
+
+(define (rule-for-calls proc+args node depth return?)
+  (let ((proc (car proc+args))
+	(args (cdr proc+args)))
+    (cond ((lambda-node? proc)
+	   (rule-for-let node depth proc args return?))
+	  ((primitive-node? proc)
+	   (rule-for-primitives node depth (node-form proc) args return?))
+	  (else
+	   (rule-for-unknown-calls node depth proc+args return?)))))
+
+(define name-node? (node-predicate 'name))
+(define lambda-node? (node-predicate 'lambda))
+(define literal-node? (node-predicate 'literal))
+(define primitive-node? (node-predicate 'primitive))
+
+(define (rule-for-let node depth proc args return?)
+  (let ((depth (+ depth 1))
+	(uid (unique-id))
+	(proc (node-form proc)))
+    (do ((names (cadr proc) (cdr names))
+	 (vals args (cdr vals)))
+	((null? names))
+      (let ((type (schemify-type (infer-type (car vals) depth) depth)))
+	(if (type-scheme? type)
+	    (set-node-type! (car names) type)
+	    (unify! (initialize-name-node-type (car names) uid depth)
+		    type
+		    node))))
+    (infer-tail-type (caddr proc) depth return?)))
+
+(define (rule-for-primitives node depth primitive args return?)
+  ((primitive-inference-rule primitive)
+     args node depth return?))
+
+(define (rule-for-unknown-calls node depth proc+args return?)
+  (let ((proc-type (infer-type (car proc+args) depth))
+	(arg-types (infer-types (cdr proc+args) depth))
+	(return-type (if return?
+			 (make-tuple-uvar 'result depth)
+			 (make-uvar 'result depth))))
+    (unify! proc-type
+	    (make-arrow-type arg-types return-type)
+	    node)
+    (unknown-value (maybe-follow-uvar return-type))))
+  
+(define (infer-types nodes depth)
+  (map (lambda (node)
+	 (infer-type node depth))
+       nodes))
+
+(define-inference-rule 'begin
+  (lambda (node depth return?)
+    (let ((exps (cdr (node-form node))))
+      (if (null? exps)
+	  (unknown-value type/unit)
+	  (let loop ((exps exps))
+	    (if (null? (cdr exps))
+		(infer-tail-type (car exps) depth return?)
+		(begin
+		  (infer-tail-type (car exps) depth #t)
+		  (loop (cdr exps)))))))))
+
+; It would be nice if we could just try to unify the two arms and return
+; type/unit if we lost, but unification has side-effects.
+
+(define-inference-rule 'if
+  (lambda (node depth return?)
+    (let ((args (cdr (node-form node))))
+      (receive (test-type test-true-asserts test-false-asserts)
+	  (infer-tail-type (car args) depth #f)
+	(unify! test-type type/boolean node)
+	(receive (cons-type cons-true-asserts cons-false-asserts)
+	    (with-assertions test-true-asserts
+	      (lambda ()
+		(infer-tail-type (cadr args) depth return?)))
+	  (receive (alt-type alt-true-asserts alt-false-asserts)
+	    (with-assertions test-false-asserts
+	      (lambda ()
+		(infer-tail-type (caddr args) depth return?)))
+	    (values (cond ((eq? cons-type type/null)
+			   alt-type)
+			  ((eq? alt-type type/null)
+			   cons-type)
+			  (else
+			   (unify! cons-type alt-type node)
+			   cons-type))
+		    (assertion-or (assertion-and test-true-asserts
+						 cons-true-asserts)
+				  (assertion-and test-false-asserts
+						 alt-true-asserts))
+		    (assertion-or (assertion-and test-true-asserts
+						 cons-false-asserts)
+				  (assertion-and test-false-asserts
+						 alt-false-asserts)))))))))
+
+(define-inference-rule 'letrec
+  (lambda (node depth return?)
+    (let ((form (node-form node))
+	  (depth (+ depth 1))
+	  (uid (unique-id)))
+      (let ((names (map car (cadr form)))
+	    (vals (map cadr (cadr form))))
+	(for-each (lambda (name)
+		    (initialize-name-node-type name uid depth))
+		  names)
+	(do ((names names (cdr names))
+	     (vals vals (cdr vals)))
+	    ((null? names))
+	  (unify! (infer-type (car vals) depth)
+		  (node-type (car names))
+		  node))
+	(for-each (lambda (name)
+		    (let ((type (schemify-type (node-type name) depth)))
+		      (if (type-scheme? type)
+			  (set-node-type! name type))))
+		  names)
+	(infer-tail-type (caddr form) depth return?)))))
+
+;--------------------------------------------------
+
+(define (node-type node)
+  (maybe-follow-uvar (node-ref node 'type)))
+
+(define (set-node-type! node type)
+  (node-set! node 'type type))
+
+(define (lambda-node-return-type node)
+  (node-ref node 'return-type))
+
+(define (set-lambda-node-return-type! node type)
+  (node-set! node 'return-type type))
+
+;--------------------------------------------------
+; Utility procedures used by the inferencers of the various primops.
+
+; Check that the INDEX'th argument of CALL has type TYPE.
+
+(define (check-arg-type args index type depth exp)
+  (if (null? args)
+      (begin
+	(format #t "Wrong number of arguments in ~S~% " (schemify exp))
+	(if *currently-checking*
+	    (format #t "~% while reconstructing the type of '~S'" *currently-checking*))
+	(error "type problem")))
+  (unify! (infer-type (list-ref args index) depth)
+	  type
+	  exp))
+
diff --git a/ps-compiler/prescheme/unused/ps-syntax.scm b/ps-compiler/prescheme/unused/ps-syntax.scm
new file mode 100644
index 0000000..a7e08ce
--- /dev/null
+++ b/ps-compiler/prescheme/unused/ps-syntax.scm
@@ -0,0 +1,116 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+; Redefine CASE so that it doesn't call MEMV
+
+(define-syntax case
+  (lambda (e r c)
+    (let ((x (r 'x))
+	  (xlet (r 'let))
+	  (xcond (r 'cond))
+	  (xif (r 'if))
+	  (xeq? (r 'eq?))
+	  (xquote (r 'quote)))
+      (let ((test (lambda (y)
+		    `(,xeq? ,x (,xquote ,y)))))
+	`(,xlet ((,x ,(cadr e)))
+		(,xcond . ,(map (lambda (clause)
+				  (if (c (car clause) 'else)
+				      clause
+				      `(,(let label ((xs (car clause)))
+					   (cond ((null? xs) #f)
+						 ((null? (cdr xs))
+						  (test (car xs)))
+						 (else
+						  `(,xif ,(test (car xs))
+							 #t
+							 ,(label (cdr xs))))))
+					. ,(cdr clause))))
+				(cddr e))))))))
+
+; RECEIVE (from big-scheme)
+
+(define-syntax receive
+  (syntax-rules ()
+    ((receive ?vars ?producer . ?body)
+     (call-with-values (lambda () ?producer)
+		       (lambda ?vars . ?body)))))
+
+
+(define-syntax external
+  (lambda (e r c)
+    (let ((l (length e)))
+      (if (and (or (= l 3) (= l 4))
+	       (string? (cadr e)))
+	  `(,(r 'real-external) ,(cadr e) ',(caddr e))
+	  e))))
+
+; DEFINE-EXTERNAL-ENUMERATION (from prescheme)
+
+(define-syntax define-external-enumeration
+  (lambda (form rename compare)
+    (let* ((name (cadr form))
+	   (symbol->upcase-string
+	    (lambda (s)
+	      (list->string (map (lambda (c)
+				   (if (char=? c #\-)
+				       #\_
+				       (char-upcase c)))
+				 (string->list (symbol->string s))))))
+	   (constant
+	    (lambda (sym string)
+	      `(,(rename 'make-external-constant) ',name ',sym ,string)))
+	   (conc (lambda things
+		   (string->symbol (apply string-append
+					  (map (lambda (thing)
+						 (if (symbol? thing)
+						     (symbol->string thing)
+						     thing))
+					       things)))))
+	   (var-name
+	    (lambda (sym)
+	      (conc name "/" sym)))
+	   (components
+	    (list->vector
+	     (map (lambda (stuff)
+		    (if (pair? stuff)
+			(cons (car stuff)
+			      (var-name (car stuff)))
+			(cons stuff
+			      (var-name stuff))))
+		  (caddr form))))
+	   (%define (rename 'define))
+	   (%define-syntax (rename 'define-syntax))
+	   (%begin (rename 'begin))
+	   (%quote (rename 'quote))
+	   (%make-external-constant (rename 'make-external-constant))
+	   (e-name (conc name '- 'enumeration))
+	   (count (vector-length components)))
+      `(,%begin
+	(,%define-syntax ,name
+	    (let ((components ',components))
+	      (lambda (e r c)
+		(let ((key (cadr e)))
+		  (cond ((c key 'enum)
+			 (let ((which (caddr e)))
+			   (let loop ((i 0)) ;vector-posq
+			     (if (< i ,count)
+				 (if (c which (car (vector-ref components i)))
+				     (r (cdr (vector-ref components i)))
+				     (loop (+ i 1)))
+				 ;; (syntax-error "unknown enumerand name"
+				 ;;               `(,(cadr e) ,(car e) ,(caddr e)))
+				 e))))
+			(else e))))))
+	(,%define ,(conc name '- 'count) ,count)
+        . ,(map (lambda (stuff)
+		  (if (pair? stuff)
+		      `(,%define ,(var-name (car stuff))
+			   (,%make-external-constant ',name
+						     ',(car stuff)
+						     ,(cadr stuff)))
+		      `(,%define ,(var-name stuff)
+			   (,%make-external-constant ',name
+						     ',stuff
+						     ,(symbol->upcase-string stuff)))))
+		(caddr form)))))
+    (begin define define-syntax quote external make-external-constant))
diff --git a/ps-compiler/prescheme/unused/record.scm b/ps-compiler/prescheme/unused/record.scm
new file mode 100644
index 0000000..9688698
--- /dev/null
+++ b/ps-compiler/prescheme/unused/record.scm
@@ -0,0 +1,19 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+
+; (make-record 'type-id)
+; (record-ref <record> 'type-id 'field-id)
+; (record-set! <record> <value> 'type-id 'field-id)
+
+(define-polymorphic-scheme-primop make-record allocate
+  (lambda (call)
+    (get-record-type (literal-value (node-ref call 0)))))
+
+(define-polymorphic-scheme-primop record-ref read
+  (lambda (call)
+    (record-field-type
+     (get-record-type-field (get-record-type (literal-value (node-ref call 1)))
+			    (literal-value (node-ref call 2))))))
+
+(define-scheme-primop record-set! write type/unit)
diff --git a/ps-compiler/prescheme/unused/track-read.scm b/ps-compiler/prescheme/unused/track-read.scm
new file mode 100644
index 0000000..702aad5
--- /dev/null
+++ b/ps-compiler/prescheme/unused/track-read.scm
@@ -0,0 +1,285 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+; Scheme48 reader modified to annotate pairs with source line and column
+; data.
+
+(define-record-type annotation
+  (
+   file
+   row
+   column
+   )
+  (form
+   ))
+
+(define $current-annotating-port (make-fluid #f))
+
+(define-syntax define-lap
+  (lambda (exp rename compare)
+    (let ((spec (cadr exp))
+	  (stuff (cddr exp)))
+      `(define ,(car spec) (lap ,spec . ,stuff)))))
+
+(define-lap (annotated-cons car cdr annotation)
+  (check-nargs= 3)
+  (pop)
+  (make-stored-object 3 pair)
+  (return))
+
+(define (file-annotated-cons car cdr row column)
+  (let* ((note (annotation-maker (fluid $current-annotating-port)
+				 row
+				 column))
+	 (pair (annotated-cons car cdr note)))
+    (set-annotation-form! note pair)
+    (make-immutable! note)
+    (make-immutable! pair)
+    pair))
+
+(define-lap (pair-annotation pair)
+  (check-nargs= 1)
+  (make-env 1)
+  (local pair)
+  (stored-object-length pair)
+  (push)
+  (literal 3)
+  (=)
+  (jump-if-false lose)
+  (local pair)
+  (stored-object-ref pair 2)  ; this is the reason for the LAP
+  (return)
+ lose
+  (false)
+  (return))
+
+; A little Scheme reader.
+
+; Nonstandard things needed:
+;  char->ascii, ascii->char (for dispatch table)
+;  make-fluid, fluid (used only to implement ##)
+;  reverse-list->string (ok to define as list->string of reverse)
+;  really-string->symbol (ok to define this to be string->symbol)
+
+(define preferred-case
+  (if (char=? (string-ref (symbol->string 't) 0) #\T)
+      char-upcase
+      char-downcase))
+
+(define close-paren (list 'close-paren))
+(define dot         (string->symbol "."))
+
+(define (read-and-annotate port id)
+  (let-fluid $current-annotating-port id
+    (lambda ()
+      (let loop ()
+	(let ((form (sub-read port)))
+	  (cond ((eq? form dot)
+		 (error "\" . \" in illegal context"))
+		((eq? form close-paren)
+		 ;; Too many right parens.
+		 (loop))
+		(else form)))))))
+
+(define (sub-read-carefully port)
+  (let ((form (sub-read port)))
+    (cond ((eof-object? form)
+           (error "unexpected end of file"))
+          ((eq? form close-paren)
+           (error "unexpected right parenthesis"))
+          ((eq? form dot)
+           (error "unexpected \" . \""))
+          (else form))))
+
+; Main dispatch
+
+(define (sub-read port)
+  (let ((c (read-char port)))
+    (if (eof-object? c)
+        c
+        ((vector-ref read-dispatch-vector (char->ascii c))
+         c port))))
+
+(define read-dispatch-vector
+  (make-vector 256
+               (lambda (c port)
+                 (error "illegal character read" c))))
+
+(define read-terminating?-vector
+  (make-vector 256 #t))
+
+(define (set-standard-syntax! char terminating? reader)
+  (vector-set! read-dispatch-vector     (char->ascii char) reader)
+  (vector-set! read-terminating?-vector (char->ascii char) terminating?))
+
+(let ((sub-read-whitespace
+       (lambda (c port)
+         c                              ;ignored
+         (sub-read port))))
+  (do ((i 0 (+ i 1)))
+      ((>= i (vector-length read-dispatch-vector)))
+    (if (char-whitespace? (ascii->char i))
+	(vector-set! read-dispatch-vector i sub-read-whitespace))))
+
+(let ((sub-read-constituent
+       (lambda (c port)
+	 (parse-token (sub-read-token c port)))))
+  (for-each (lambda (c)
+              (set-standard-syntax! c #f sub-read-constituent))
+            (string->list
+             (string-append "!$%&*+-./0123456789:<=>?@^_~ABCDEFGHIJKLM"
+                            "NOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"))))
+
+; Usual read macros
+
+(define (set-standard-read-macro! c terminating? proc)
+  (set-standard-syntax! c terminating? proc))
+
+(define (sub-read-list c port)
+  (let* ((row (current-row port))
+	 (column (- (current-column port) 1))  ; to get the location of "("
+	 (form (sub-read port)))
+    (cond ((eof-object? form)
+           (error "end of file inside list -- unbalanced parentheses"))
+          ((eq? form close-paren) '())
+          ((eq? form dot)
+           (let* ((last-form (sub-read-carefully port))
+                  (another-form (sub-read port)))
+             (cond ((eq? another-form close-paren)
+		    last-form)
+                   (else
+                    (error "randomness after form after dot" another-form)))))
+          (else
+	   (file-annotated-cons form (sub-read-list c port) row column)))))
+
+(set-standard-read-macro! #\( #t sub-read-list)
+
+(set-standard-read-macro! #\) #t
+  (lambda (c port)
+    c port
+    close-paren))
+
+(set-standard-read-macro! #\' #t
+  (lambda (c port)
+    c
+    (list 'quote (sub-read-carefully port))))
+
+(set-standard-read-macro! #\` #t
+  (lambda (c port)
+    c
+    (list 'quasiquote (sub-read-carefully port))))
+
+(set-standard-read-macro! #\, #t
+  (lambda (c port)
+    c
+    ;; Do not beta-reduce this!
+    (let* ((next (peek-char port))
+	   (marker (cond ((eof-object? next)
+			  (error "end of file after ,"))
+			 ((char=? next #\@)
+			  (read-char port)
+			  'unquote-splicing)
+			 (else 'unquote))))
+      (list marker
+            (sub-read-carefully port)))))
+
+(set-standard-read-macro! #\" #t
+  (lambda (c port)
+    c ;ignored
+    (let loop ((l '()) (i 0))
+      (let ((c (read-char port)))
+        (cond ((eof-object? c)
+               (error "end of file within a string"))
+              ((char=? c #\\)
+               (let ((c (read-char port)))
+		 (cond ((eof-object? c)
+			(error "end of file within a string"))
+		       ((or (char=? c #\\) (char=? c #\"))
+			(loop (cons c l) (+ i 1)))
+		       (else
+			(error "invalid escaped character in string" c)))))
+              ((char=? c #\")
+	       (reverse-list->string l i))
+              (else
+	       (loop (cons c l) (+ i 1))))))))
+
+(set-standard-read-macro! #\; #t
+  (lambda (c port)
+    c ;ignored
+    (gobble-line port)
+    (sub-read port)))
+
+(define (gobble-line port)
+  (let loop ()
+    (let ((c (read-char port)))
+      (cond ((eof-object? c) c)
+	    ((char=? c #\newline) #f)
+	    (else (loop))))))
+
+(set-standard-read-macro! #\# #f
+  (lambda (c port)
+    c ;ignored
+    (let* ((c (peek-char port))
+	   (c (if (eof-object? c)
+		  (error "end of file after #")
+		  (char-downcase c))))
+      (cond ((char=? c #\f) (read-char port) #f)
+            ((char=? c #\t) (read-char port) #t)
+            ((char=? c #\\)
+	     (read-char port)
+             (let ((c (peek-char port)))
+               (cond ((eof-object? c)
+		      (error "end of file after #\\"))
+		     ((char-alphabetic? c)
+		      (let ((name (sub-read-carefully port)))
+			(cond ((= (string-length (symbol->string name)) 1)
+			       c)
+			      ((assq name '((space   #\space)
+					    (newline #\newline)))
+			       => cadr)
+			      (else
+			       (error "unknown #\\ name" name)))))
+		     (else
+		      (read-char port)))))
+            ((char=? c #\()
+	     (read-char port)
+             (list->vector (sub-read-list c port)))
+            ;; ## should evaluate to the last REP-loop result.
+            ((memq c '(#\b #\o #\d #\x #\i #\e))
+	     (let ((string (sub-read-token #\# port)))
+	       (or (string->number string)
+		   (error "unsupported number syntax" string))))
+;            ((char=? c #\#)   ; don't worry about this
+;	     (read-char port)
+;	     (make-last-value-expression))
+            (else
+             (error "unknown # syntax" c))))))
+
+
+; Tokens
+
+(define (sub-read-token c port)
+  (let loop ((l (list (preferred-case c))) (n 1))
+    (let ((c (peek-char port)))
+      (cond ((or (eof-object? c)
+                 (vector-ref read-terminating?-vector (char->ascii c)))
+             (reverse-list->string l n))
+            (else
+             (loop (cons (preferred-case (read-char port)) l)
+                   (+ n 1)))))))
+
+(define (parse-token string)
+  (if (let ((c (string-ref string 0)))
+	(or (char-numeric? c) (char=? c #\+) (char=? c #\-) (char=? c #\.)))
+      (cond ((string->number string))
+	    ((member string strange-symbol-names)
+	     (string->symbol string))
+	    ((string=? string ".")
+	     dot)
+	    (else
+	     (error "unsupported number syntax" string)))
+      (string->symbol string)))
+
+(define strange-symbol-names
+  '("+" "-" "..." "1+" "-1+"))  ;The latter two only for S&ICP support
diff --git a/ps-compiler/prescheme/unused/user.scm b/ps-compiler/prescheme/unused/user.scm
new file mode 100644
index 0000000..4a807bd
--- /dev/null
+++ b/ps-compiler/prescheme/unused/user.scm
@@ -0,0 +1,104 @@
+; Copyright (c) 1994 by Richard Kelsey.  See file COPYING.
+
+
+(define *break-on-user-errors?* #f)
+
+(define (user-error node string . args)
+  (format #t "~%PreScheme error: ")
+  (apply format #t string args)
+  (newline)
+  (if node (display-source node))
+  (if *break-on-user-errors?*
+      (breakpoint "")))
+
+(define (display-source node)
+  (let ((source-node (find-some-source node)))
+    (if source-node
+	(display-annotation (node-source source-node)
+			    (eq? source-node node)
+			    node)
+	(pp-cps (top-call node)))))
+
+(define (top-call node)
+  (let loop ((node node))
+    (if (or (not (node? (node-parent node)))
+	    (and (call-node? node)
+		 (not (call-node? (node-parent node)))))
+	node
+	(loop (node-parent node)))))
+
+(define (node-source node)
+  (cond ((call-node? node)
+	 (call-source node))
+	((lambda-node? node)
+	 (lambda-source node))
+	(else
+	 #f)))
+
+(define (find-some-source node)
+  (let loop ((node node))
+    (cond ((not (node? node))
+	   #f)
+	  ((annotation? (node-source node))
+	   node)
+	  (else (loop (node-parent node))))))
+
+(define (display-annotation annotation exact? node)
+  (let ((file   (annotation-file annotation))
+	(form   (annotation-form annotation))
+	(row    (annotation-row annotation))
+	(column (annotation-column annotation)))
+    (newline)
+    (cond (exact?
+	   (display "  "))
+	  (else
+	   (write-one-line (current-output-port)
+			   60
+			   (lambda (port)
+			     (show-user-node node port)))
+	   (display "  within ")))
+    (newline)
+    (write-one-line (current-output-port)
+		    70
+		    (lambda (port) (display form port)))
+    (format #t "~%    on line ~D of ~A~%" column file)))
+
+(define (show-user-node node port)
+  (cond ((literal-node? node)
+	 (format port "'~S" (literal-value node)))
+	((reference-node? node)
+	 (format port "~S" (variable-name (reference-variable node))))
+	((lambda-node? node)
+	 (format port "(lambda ~A ...)"
+		 (map variable-name
+		      (if (proc-lambda? node)
+			  (cdr (lambda-variables node))
+			  (lambda-variables node))))
+	 (show-user-node (lambda-body node) port))
+	((call-node? node)
+	 (show-user-call-node node port))))
+
+(define (show-user-call-node call port)
+  (let ((exits (call-exits call))
+	(id (primop-id (call-primop call))))
+    (case id
+      ((let)
+       (display "(let ..." port)	; wimpy
+       )
+      ((call unknown-call)
+       (display "(" port)
+       (show-user-node (call-arg call 1) port)
+       (show-user-call-args call (if (eq? 'call id) 2 3) port)
+       (display ")" port))
+      (else				; wimpy
+       (format port "(~S" id)
+       (show-user-call-args call exits port)
+       (format port ")")))))
+
+(define (show-user-call-args call start port)
+  (do ((i start (+ i 1)))
+      ((>= i (call-arg-count call)))
+    (display " " port)
+    (show-user-node (call-arg call i) port)))
+       
+      
\ No newline at end of file
diff --git a/ps-compiler/simp/call.scm b/ps-compiler/simp/call.scm
new file mode 100644
index 0000000..4925518
--- /dev/null
+++ b/ps-compiler/simp/call.scm
@@ -0,0 +1,251 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+(define (simplify-jump call)
+  (cond ((lambda-node? (call-arg call 0))
+	 (set-call-primop! call (get-primop (enum primop let)))
+	 (set-call-exits! call 1)
+	 (set-node-simplified?! call #f))
+	(else
+	 (default-simplifier call))))
+
+(define simplify-return simplify-jump)
+
+; If the procedure is a lambda-node:
+;   1. note that we know where the continuation lambda is used (and turn any
+;      tail-calls using it into regular calls)
+;   2. change the primop to LET
+;   3. the procedure is now the continuation
+;   4. the continuation is now a jump lambda
+;   5. change the primop used to call the continuation to jump
+;   6. swap the cont and proc.
+;   (CALL <cont> (LAMBDA (c . vars) ...) . args))
+;     =>
+;   (LET (LAMBDA (c . vars) ...) <cont> . args)
+; If the continuation just returns somewhere else, replace UNKNOWN-CALL
+; with UNKNOWN-TAIL-CALL.
+
+(define (simplify-known-call call)
+  (let ((proc (call-arg call 1))
+	(cont (call-arg call 0)))
+    (cond ((lambda-node? proc)
+	   (determine-continuation-protocol cont (list proc))
+	   (set-call-primop! call (get-primop (enum primop let)))
+	   (change-lambda-type proc 'cont)
+	   (change-lambda-type cont 'jump)
+	   (for-each (lambda (ref)
+		       (set-call-primop! (node-parent ref)
+					 (get-primop (enum primop jump))))
+		     (variable-refs (car (lambda-variables proc))))
+	   (move cont
+		 (lambda (cont)
+		   (detach proc)
+		   (attach call 1 cont)
+		   proc)))
+	  ((trivial-continuation? cont)
+	   (replace cont (detach (call-arg (lambda-body cont) 0)))
+	   (set-call-primop! call (get-primop (enum primop tail-call)))
+	   (set-call-exits! call 0))
+	  (else
+	   (default-simplifier call)))))
+
+;  (CALL (CONT (v1 ... vN) (RETURN c v1 ... vN)) ...args...)
+
+(define (trivial-continuation? cont)
+  (let ((body (lambda-body cont)))
+    (and (calls-this-primop? body 'return)
+	 (= (length (lambda-variables cont))
+	    (- (call-arg-count body ) 1))
+	 (let loop ((vars (lambda-variables cont)) (i 1))
+	   (cond ((null? vars)
+		  #t)
+		 ((and (reference-node? (call-arg body i))
+		       (eq? (car vars)
+			    (reference-variable (call-arg body i))))
+		  (loop (cdr vars) (+ i 1)))
+		 (else #f))))))
+
+; The same as the above, except that the continuation is a reference node
+; and not a lambda, so we substitute it for the proc's continuation variable.
+
+(define (simplify-known-tail-call call)
+  (let ((proc (call-arg call 1))
+	(cont (call-arg call 0)))
+    (cond ((lambda-node? proc)
+	   (set-call-primop! call (get-primop (enum primop let)))
+	   (change-lambda-type proc 'cont)
+	   (substitute (car (lambda-variables proc)) cont #t)
+	   (set-lambda-variables! proc (cdr (lambda-variables proc)))
+	   (remove-call-arg call 0)
+	   (set-call-exits! call 1)  ; must be after REMOVE-CALL-ARG
+	   (mark-changed proc))
+	  (else
+	   (default-simplifier call)))))
+
+(define (simplify-test call)
+  (simplify-arg call 2)
+  (let ((value (call-arg call 2)))
+    (cond ((literal-node? value)
+	   (fold-conditional call (if (eq? false-value (literal-value value))
+				      1
+				      0)))
+	  ((reference-node? value)
+	   (simplify-variable-test call (reference-variable value)))
+	  ((collapse-multiple-zero-bit-tests call)
+	   )
+	  (else
+	   (default-simplifier call)))))
+
+(define (simplify-variable-test call var)
+  (cond ((flag-assq 'test (variable-flags var))
+	 => (lambda (pair)
+	      (fold-conditional call (cdr pair))))
+	(else
+	 (let ((pair (cons 'test 0))
+	       (flags (variable-flags var)))
+	   (set-variable-flags! var (cons pair flags))
+	   (simplify-arg call 0)
+	   (set-cdr! pair 1)
+	   (simplify-arg call 1)
+	   (set-variable-flags! var flags)))))
+
+(define (fold-conditional call index)
+  (replace-body call (detach-body (lambda-body (call-arg call index)))))
+
+; (if (and (= 0 (bitwise-and 'j x))
+;          (= 0 (bitwise-and 'j y)))
+;     ...)
+; =>
+; (if (= 0 (bitwise-and (bitwise-or x y) 'j))
+;     ...)
+; This comes up in the Scheme48 VM.
+
+(define (collapse-multiple-zero-bit-tests test)
+  (receive (mask first-arg)
+      (zero-bit-test (call-arg test 2))
+    (if mask
+	(let ((false-exit (call-arg test 1))
+	      (true-exit (call-arg test 0)))
+	  (simplify-lambda-body true-exit)
+	  (simplify-lambda-body false-exit)
+	  (let ((call (lambda-body true-exit)))
+	    (if (and (eq? 'test (primop-id (call-primop call)))
+		     (node-equal? false-exit (call-arg call 1)))
+		(receive (new-mask second-arg)
+		    (zero-bit-test (call-arg call 2))
+		  (if (and new-mask (= mask new-mask))
+		      (fold-zero-bit-tests test first-arg second-arg
+					   (call-arg call 0))
+		      #f))
+		#f)))
+	#f)))
+
+; = and bitwise-and always have any literal node as arg1
+;
+; 1. call to =
+; 2. first arg is literal 0
+; 3. second arg is call to and
+; 4. first arg of and-call is numeric literal
+; 5. second arg of and-call has no side-effects (reads are okay)
+;  Returns #f or the two arguments to bitwise-and.
+
+(define (zero-bit-test call)
+  (if (eq? '= (primop-id (call-primop call)))
+      (let ((literal-0 (call-arg call 0))
+	    (bitwise-and-call (call-arg call 1)))
+	(if (and (literal-node? literal-0)
+		 (number? (literal-value literal-0))
+		 (= 0 (literal-value literal-0))
+		 (call-node? bitwise-and-call)
+		 (eq? 'bitwise-and (primop-id (call-primop bitwise-and-call)))
+		 (literal-node? (call-arg bitwise-and-call 0))
+		 (number? (literal-value (call-arg bitwise-and-call 0)))
+		 (not (side-effects? (call-arg bitwise-and-call 1) 'read)))
+	    (values (literal-value (call-arg bitwise-and-call 0))
+		    (call-arg bitwise-and-call 1))
+	    (values #f #f)))
+      (values #f #f)))
+
+(define (fold-zero-bit-tests test first-arg second-arg true-cont)
+  (detach second-arg)
+  (replace (call-arg test 0) (detach true-cont))
+  (move first-arg
+	(lambda (first-arg)
+	  (let-nodes ((call (bitwise-ior 0 first-arg second-arg)))
+	    call))))
+
+(define (expand-test call)
+  (bug "Trying to expand a call to TEST (~D) ~S"
+       (node-hash (node-parent (nontrivial-ancestor call)))))
+
+; TEST can be simplified using any literal value.
+; The check for reference nodes is a heuristic.  It will only help if the
+; two tests end up being sequential.
+
+(define (simplify-test? call index value)
+  (cond ((literal-node? value)
+	 #t)
+	((reference-node? value)
+	 (any? (lambda (r)
+		 (eq? 'test (primop-id (call-primop (node-parent r)))))
+	       (variable-refs (reference-variable value))))
+	(else
+	 #f)))
+
+(define (simplify-unknown-call call)
+  (simplify-args call 0)
+  (let ((proc (call-arg call 1)))
+    (cond ((lambda-node? proc)
+	   (determine-lambda-protocol proc (list proc))
+	   (mark-changed proc))
+	  ((and (reference-node? proc)
+		(variable-simplifier (reference-variable proc)))
+           => (lambda (proc)
+		(proc call))))))
+
+; Simplify a cell.  A set-once cell is one that is set only once and does
+; not escape.  If such a cell is set to a value that can be hoisted (without
+; moving variables out of scope) to the point the cell is created the cell
+; is replace with the value.
+
+; This should make use of the type of the cell.
+
+(define (simplify-allocation call)
+  (set-node-simplified?! call #t)
+  (simplify-args call 0)    ; simplify all arguments, including continuation
+  (let ((var (car (lambda-variables (call-arg call 0)))))
+    (if (every? cell-use? (variable-refs var))
+	(receive (uses sets)
+	    (partition-list (lambda (n)
+			      (eq? 'contents
+				   (primop-id (call-primop (node-parent n)))))
+			    (variable-refs var))
+	  (simplify-cell-part call uses sets)))))
+
+(define (cell-use? ref)
+  (let ((call (node-parent ref)))
+    (case (primop-id (call-primop call))
+      ((contents)
+       #t)
+      ((set-contents)
+       (= (node-index ref) set/owner))
+      (else
+       #f))))
+
+(define (simplify-cell-part call my-uses my-sets)
+  (cond ((null? my-uses)
+         (for-each (lambda (n) (remove-body (node-parent n)))
+		   my-sets))
+        ((null? my-sets)
+         (for-each (lambda (n)
+		     (replace-call-with-value
+		      (node-parent n)
+		      (make-undefined-literal)))
+		   my-uses))
+;        ((null? (cdr my-sets))
+;	  (set-literal-value! (call-arg call 1) 'single-set)
+;	  (really-simplify-single-set call (car my-sets) my-uses))
+	(else
+	 (if (neq? 'small (literal-value (call-arg call 1)))
+	     (set-literal-value! (call-arg call 1) 'small)))))
+	     
diff --git a/ps-compiler/simp/join.scm b/ps-compiler/simp/join.scm
new file mode 100644
index 0000000..a9f0ac1
--- /dev/null
+++ b/ps-compiler/simp/join.scm
@@ -0,0 +1,223 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+; Call JOIN-SUBSTITUTE on all variable/value pairs.
+
+(define (substitute-join-arguments lambda-proc call)
+  (let ((vec (call-args call))
+        (vars (lambda-variables lambda-proc)))
+    (do ((vars vars (cdr vars))
+         (i    1   (+ i 1))
+         (c?   #f  (or (join-substitute (car vars) (vector-ref vec i))
+                        c?)))
+        ((null? vars) c?))))
+
+; Does VAL take only one argument and is that argument passed to $TEST?
+; Is VAR applied to constants?
+; Then two possiblities are checked for:
+;   Does the tree rooted at the least-common-ancestor of VAR's references
+;   contain no side-effects and necessarily passed control to VAR?
+;  or
+;   Does the join point contain no side-effects above the test?
+;
+; If so, make the transformation described below.
+
+(define (join-substitute var val)
+  (let ((ref (and (lambda-node? val)
+		  (simple-test-procedure val))))
+    (and ref
+	 (applied-to-useful-value? var ref)
+	 (let ((lca (least-common-ancestor (variable-refs var))))
+	   (cond ((or (suitable-join-conditional? lca var)
+		      (suitable-join-point? val (node-parent ref)))
+		  (really-join-substitute var val lca (node-parent ref))
+		  #t)
+		 (else #f))))))
+
+; Check that VAL (a lambda-node) takes one argument, is jumped to, tests its
+; argument, and that all references to the argument are at or below the test.
+
+(define (simple-test-procedure val)
+  (let ((vars (lambda-variables val)))
+    (if (or (null? vars)
+	    (not (null? (cdr vars)))
+	    (not (car vars))
+	    (not (calls-known? val))
+	    (neq? 'jump (lambda-type val)))
+	#f
+	(let* ((var (car vars))
+	       (ref (any simple-cond-ref (variable-refs var))))
+	  (if (and ref (all-refs-below? var (node-parent ref)))
+	      ref
+	      #f)))))
+
+(define (simple-cond-ref ref)
+  (if (primop-conditional? (call-primop (node-parent ref)))
+      ref
+      #f))
+
+(define (all-refs-below? var node)
+  (set-node-flag! node #t)
+  (set-node-flag! (variable-binder var) #t)
+  (let ((res (every? (lambda (r)
+		       (eq? node (marked-ancestor r)))
+		     (variable-refs var))))
+    (set-node-flag! node #f)
+    (set-node-flag! (variable-binder var) #f)
+    res))
+
+; Is VAR applied to something that can be used to simplify the conditional?
+
+(define (applied-to-useful-value? var ref)
+  (let ((call (node-parent ref))
+	(index (node-index ref)))
+    (any? (lambda (r)
+	    (simplify-conditional? call index (call-arg (node-parent r) 1)))
+	  (variable-refs var))))
+
+; CALL is the least-common-ancestor of the references to VAR.  Check that
+; the tree rooted at CALL contains no side-effects and that the control flow
+; necessarily passes to VAR.  (Could check for undefined-effect here...)
+; could do check that jumped-to proc if not VAR jumped to VAR eventually
+
+(define (suitable-join-conditional? call var)
+  (let label ((call call))
+    (cond ((call-side-effects? call)
+	   #f)
+	  ((= 0 (call-exits call))
+	   (and (eq? 'jump (primop-id (call-primop call)))
+		(eq? var (reference-variable (called-node call)))))
+	  (else
+	   (let loop ((i 0))
+	     (cond ((>= i (call-exits call))
+		    #t)
+		   ((not (label (lambda-body (call-arg call i))))
+		    #f)
+		   (else
+		    (loop (+ i 1)))))))))
+
+; #t if CALL performs side-effects.  The continuations to CALL are ignored.
+
+(define (call-side-effects? call)
+  (or (primop-side-effects (call-primop call))
+      (let loop ((i (call-exits call)))
+	(cond ((>= i (call-arg-count call))
+	       #f)
+	      ((side-effects? (call-arg call i))
+	       #t)
+	      (else
+	       (loop (+ i 1)))))))
+
+; The alternative to the above test: does the join point contain no side-effects
+; above the test?
+
+(define (suitable-join-point? join test)
+  (let label ((call (lambda-body join)))
+    (cond ((eq? call test)
+	   #t)
+	  ((call-side-effects? call)
+	   #f)
+	  (else
+	   (let loop ((i 0))
+	     (cond ((>= i (call-exits call))
+		    #t)
+		   ((not (label (lambda-body (call-arg call i))))
+		    #f)
+		   (else
+		    (loop (+ i 1)))))))))
+	     
+; (let ((j (lambda (v)                  ; VAR VAL
+;            .a.
+;            ($test c1 c2 ... v ...)    ; TEST
+;            .b.)))
+;   .c.
+;   (... (j x) ...)                     ; CALL
+;   .d.)
+; ==>
+; .c.
+; (.a.
+;  (let ((v1 (lambda (x) c1[x/v]))
+;        (v2 (lambda (x) c2[x/v])))
+;    (... ((lambda (v)
+;            ($test (lambda () (v1 v)) (lambda () (v2 v)) ... v ...))
+;          x)
+;     ...))
+;  .b.)
+; .d.
+;
+; CALL is the least common ancestor of the references to VAR, which is bound to
+; VAL, a procedure.  TEST is a conditional that tests the argument passed to
+; VAL.
+;
+; (lambda-body VAL) is moved to where CALL is.
+; In the body of VAL, TEST is replaced by a LET that binds TEST's continuations
+; and then executes CALL.  TEST's continuations are replaced by calls to
+; the variables bound by the LET.
+; Finally, references to VAR are replaced by a procedure whose body is TEST,
+; which is the point of the whole exercise.
+
+(define (really-join-substitute var val call test)
+  (let ((value-var (car (lambda-variables val))))
+    (receive (cont-call conts)
+	(move-continuations test call value-var)
+      (let ((test-parent (node-parent test))
+	    (val-parent (node-parent val))
+	    (val-index (node-index val)))
+	(parameterize-continuations conts value-var)
+	(detach-body test)
+	(move-body cont-call
+		   (lambda (cont-call)
+		     (attach-body test-parent cont-call)
+		     (detach-body (lambda-body val))))
+	(attach-body val test)
+	(mark-changed (call-arg test 1)) ; marks test as changed.
+	(mark-changed cont-call)
+	(substitute var val #t)
+	(attach val-parent val-index (make-literal-node #f #f))
+	(values)))))
+
+; Move the continuations of CALL to a LET call just above TO.  Returns a list
+; of the variables now bound to the continuations and the continuations
+; themselves.
+
+(define (move-continuations call to arg-var)
+  (let ((count (call-exits call)))
+    (let loop ((i (- count 1)) (vs '()) (es '()))
+      (cond ((< i 0)
+	     (let ((new-call (make-call-node (get-primop (enum primop let))
+					     (+ count 1)
+					     1))
+		   (new-proc (make-lambda-node 'j 'cont vs)))
+	       (attach-call-args new-call (cons new-proc es))
+	       (insert-body new-call new-proc (node-parent to))
+	       (values new-call es)))
+	    (else
+	     (let ((var (make-variable 'e (node-type (call-arg call i))))
+		   (cont (detach (call-arg call i))))
+	       (let-nodes ((new-cont () c1)
+			   (c1 (jump 0 (* var) (* arg-var))))
+		 (attach call i new-cont))
+	       (change-lambda-type cont 'jump)
+	       (loop (- i 1) (cons var vs) (cons cont es))))))))
+
+; Add a new variable to each of CONTS and substitute a reference to the correct
+; variable for each reference to VAR within CONTS.
+
+(define (parameterize-continuations conts var)
+  (for-each (lambda (n)
+	      (let ((var (copy-variable var)))
+		(set-lambda-variables! n (cons var (lambda-variables n)))
+		(set-variable-binder! var n)
+		(set-node-flag! n #t)))
+	    conts)
+  (let ((backstop (variable-binder var)))
+    (set-node-flag! backstop #t)
+    (walk-refs-safely
+     (lambda (n)
+       (let ((cont (marked-ancestor n)))
+	 (if (not (eq? cont backstop))
+	     (replace n (make-reference-node (car (lambda-variables cont)))))))
+     var)
+    (set-node-flag! backstop #f)
+    (for-each (lambda (n) (set-node-flag! n #f)) conts)
+    (values)))
diff --git a/ps-compiler/simp/let.scm b/ps-compiler/simp/let.scm
new file mode 100644
index 0000000..e9bff31
--- /dev/null
+++ b/ps-compiler/simp/let.scm
@@ -0,0 +1,155 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+; Simplifying LET nodes, i.e. calls to the LET primop.
+
+; 1. Change the procedure to a JUMP procedure if necessary.
+; 2. Check that the right number of arguments are present.
+; 3. Substitute any values that can be substituted without reference to
+;    how they are used in the body; then remove the call if it is no
+;    longer necessary.
+; 4. Try harder.
+
+(define (simplify-let call)
+  (let ((proc (call-arg call 0)))
+    (if (eq? (lambda-type proc) 'jump)
+	(change-lambda-type proc 'cont))
+    (cond ((n= (length (lambda-variables proc))
+	       (- (call-arg-count call) 1))
+	   (bug "wrong number of arguments in ~S" call))
+	  ((or (null? (lambda-variables proc))
+	       (substitute-let-arguments proc call quick-substitute))
+	   (remove-body call))
+	  (else
+	   (really-simplify-let proc call)))))
+
+; A value can be quickly substituted if it is a leaf node or if it has no
+; side-effects and is used only once.
+
+(define (quick-substitute var val)
+  (or (literal-node? val)
+      (reference-node? val)
+      (and (not (side-effects? val))
+	   (null? (cdr (variable-refs var))))))
+
+; Simplify the arguments and then repeatedly simplify the body of PROC
+; and try substituting the arguments.
+; If all the arguments can be substituted the call node is removed.
+;
+; SUBSTITUTE-JOIN-ARGUMENTS copies arguments in an attempt to remove
+; conditionals via constant folding.
+
+(define (really-simplify-let proc call)
+  (simplify-args call 1)
+  (let loop ()
+    (set-node-simplified?! proc #t)
+    (simplify-lambda-body proc)
+    (cond ((substitute-let-arguments proc call slow-substitute)
+	   (remove-body call))
+          ((substitute-join-arguments proc call)
+           (loop))
+          ((not (node-simplified? proc))
+           (loop)))))
+
+(define *duplicate-lambda-size* '-1)   ; don't duplicate anything
+(define *duplicate-jump-lambda-size* 1) ; duplicate one call
+
+(define (slow-substitute var val)
+  (cond ((or (literal-node? val) (reference-node? val))
+	 #t)
+	((call-node? val)
+	 (let ((refs (variable-refs var)))
+	   (and (not (null? refs))
+		(null? (cdr refs))
+		(or (not (side-effects? val 'allocate))
+		    (and (not (side-effects? val 'allocate 'read))
+			 (not-used-between? val (car refs)))))))
+	((every? called-node? (variable-refs var))
+	 (simplify-known-cont-calls (variable-refs var) val)
+	 (or (null? (cdr (variable-refs var)))
+	     (case (lambda-type val)
+	       ((proc known-proc)
+		(small-node? val *duplicate-lambda-size*))
+	       ((jump)
+		(small-node? val *duplicate-jump-lambda-size*))
+	       (else
+		#f))))
+        (else #f)))
+
+; This only detects the following situation:
+; (let (lambda (... var ...) (primop ... var ...))
+;      ... value ...)
+; where the reference to VAR is contained within nested, non-writing calls
+; This depends on there being no simple calls with WRITE side-effects
+
+(define (not-used-between? call ref)
+  (let ((top (lambda-body (call-arg (node-parent call) 0))))
+    (let loop ((call (node-parent ref)))
+      (cond ((eq? call top) #t)
+	    ((or (not (call-node? call))
+		 (eq? 'write (primop-side-effects (call-primop call))))
+	     #f)
+	    (else (loop (node-parent call)))))))
+
+(define (simplify-known-cont-calls refs l-node)
+  (case (lambda-type l-node)
+    ((proc)
+     (determine-lambda-protocol l-node refs))
+    ((cont)
+     (bug "CONT lambda bound by LET ~S" l-node)))
+  (if (calls-known? l-node)
+      (simplify-known-lambda l-node)))
+
+; ($some-RETURN <proc> . <args>)
+;   =>
+; ($JUMP <proc> . <args>)
+
+; could check argument reps as well
+
+(define (add-return-mark call l-node arg-count)
+  (if (not (= (call-arg-count call) (+ arg-count 1)))
+      (bug '"call ~S to join ~S has the wrong number of arguments"
+           call l-node))
+  (set-call-primop! call (get-primop (enum primop jump))))
+
+; Removed arguments to a lambda-node in call position.
+; If any arguments are actually removed
+; REMOVE-NULL-ARGUMENTS shortens the argument vector.
+
+(define (substitute-let-arguments node call gone-proc)
+  (let* ((vec (call-args call))
+         (c (do ((vars (lambda-variables node) (cdr vars))
+                 (i 1 (+ i 1))
+                 (c 0 (if (keep-var-val (car vars) (vector-ref vec i) gone-proc)
+			  c
+			  (+ 1 c))))
+                ((null? vars) c))))
+    (cond ((= (+ c 1) (call-arg-count call)) #t)
+          ((= c 0)                           #f)
+          (else
+           (remove-unused-variables node)
+           (remove-null-arguments call (- (call-arg-count call) c))
+           #f))))
+
+(define (keep-var-val var val gone-proc)
+  (cond ((and (unused? var)
+	      (or (not (call-node? val))
+		  (not (side-effects? val 'allocate 'read))))
+         (erase (detach val))
+         #f)
+        ((gone-proc var val)
+         (substitute var val #t)
+         #f)
+        (else '#t)))
+
+; VAL is simple enough to be substituted in more than one location if
+; its body is a call with all leaf nodes.
+; -- no longer used --
+;(define (simple-lambda? val)
+;  (vector-every? (lambda (n)
+;                   (and (not (lambda-node? n))
+;                 (call-args (lambda-body val))))
+
+(define (called-anywhere? var)
+  (any? called-node? (variable-refs var)))
+
diff --git a/ps-compiler/simp/pattern.scm b/ps-compiler/simp/pattern.scm
new file mode 100644
index 0000000..8db2236
--- /dev/null
+++ b/ps-compiler/simp/pattern.scm
@@ -0,0 +1,414 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+;(define (simplify-subtract call)
+;  (simplify-args call 0)
+;  ((pattern-simplifier
+;    ((- 'a 'b) '(- a b))                    ; constant folding
+;    ((- x 'a) (+ '(- 0 a) x))               ; convert to a normal form
+;    ((- 'a (+ 'b x)) (- '(- a b) x))        ; merging constants
+;    ((- 'a (- 'b x)) (+ x '(- a b)))        ; ditto
+;    ((- x (+ 'a y)) (+ '(- 0 a) (- x y)))   ; convert to a normal form
+;    ((- (+ 'a x) (+ 'b y)) (- (+ '(- a b) x) y)))
+;   call))
+
+; (pattern-simplifier pattern-spec ...)
+;  =>
+; (lambda (call-node) ...)
+; The resulting procedure replaces instances of IN-PATTERNs with the
+; corresponding OUT-PATTERNs.
+;
+; <pattern-spec> ::= (in-pattern out-pattern) |
+;                    (in-pattern boolean-expression out-pattern) 
+;
+; All of the IN-PATTERNs for a particular simplifier must be calls to the
+; same primop.  If the boolean-expression is present it is evaluated after
+; the in-pattern is matched and in an environment where the symbols of the
+; the in-pattern are bound to the corresponding values from the call.
+;
+; x       matches anything
+; 'x      matches any literal
+; (x ...) matches a call to primop X
+; 5       matches the literal 5
+
+; The patterns are matched in order.
+
+;----------------
+; Call MATCH-CALLS with a continuation that makes code to construct the
+; right-hand side of the specification.  This assumes that the left-hand side
+; of all of the specifications will be calls to the same primitive.  The
+; initial CASE is removed from the code returned by MATCH-CALLS.
+
+(define (make-pattern-simplifier specs)
+  (set! *generate-symbol-index* 0)
+  (let* ((initial (generate-symbol 'initial))
+	 (exp (match-calls (map (lambda (spec)
+				  (make-pattern (car spec) (cdr spec)))
+				specs)
+			   initial
+			   #f
+			   (lambda (patterns)
+			     (if (null? patterns)
+				 (error "no patterns matched" specs)
+				 (check-predicates patterns initial))))))
+    `(lambda (,initial)
+       ,(cadar (cddr exp))))) ; strip off initial CASE
+
+(define-record-type pattern
+  (spec        ; the specification this pattern is to match
+   (env)       ; an a-list mapping atoms in the pattern to the identifiers
+               ; that will be bound to the value matched by the atom
+   parent      ; if this pattern is an argument in another pattern, this
+               ; field contains the other pattern
+   predicate   ; predicate call or #F
+   build-spec  ; specification for the transformed pattern
+   )
+  ())
+
+; Returns the pattern for the I'th argument in PATTERN.
+
+(define (pattern-arg pattern i)
+  (list-ref (pattern-spec pattern) (+ i 1)))
+
+(define (make-pattern spec specs)
+  (receive (build-spec predicate)
+      (if (null? (cdr specs))
+	  (values (car specs) #f)
+	  (values (cadr specs) (car specs)))
+    (pattern-maker spec '() #f predicate build-spec)))
+
+; For each pattern in PATTERN, extend the environment with the I'th argument
+; of the pattern bound to ID.
+
+(define (extend-pattern-envs patterns i id)
+  (map (lambda (pattern)
+	 (let ((arg (pattern-arg pattern i)))
+	   (set-pattern-env! pattern
+			     (cons (if (pair? arg)
+				       (list (cadr arg) id #t)
+				       (list arg id #f))
+				   (pattern-env pattern)))))
+       patterns))
+
+; Return the parent of PATTERN, setting the environment of the parent to be
+; the environment of PATTERN.  This is only used once we are done with PATTERN
+; and want to continue with the next argument in the parent.
+
+(define (get-pattern-parent pattern)
+  (let ((p (pattern-parent pattern)))
+    (set-pattern-env! p (pattern-env pattern))
+    p))
+
+; Sort PATTERNS by the primop being called, and for each set of patterns
+; matching the same primop, call MATCH-CALL-ARGS to generate code for
+; those patterns.  FINISH-CALL-MATCH builds the clauses that this generates
+; into a CASE expression.
+; CALL-VAR is the identifier that will be bound to the call being matched.
+; FAIL-VAR is either #f or a variable that should be called if no pattern
+; matches.
+; MORE is a procedure that finishes with the patterns after this call has
+; been matched.
+
+(define (match-calls patterns call-var fail-var more)
+  (let ((primop-var (generate-symbol 'primop)))
+    (let loop ((patterns patterns) (res '()))
+      (if (null? patterns)
+	  (finish-call-match res call-var primop-var fail-var)
+	  (let ((primop (car (pattern-spec (car patterns)))))
+	    (receive (same other)
+		(partition-list (lambda (p)
+				  (eq? primop (car (pattern-spec p))))
+				(cdr patterns))
+	      (loop other
+		    (cons `(,(if (number? primop) 'else `(,primop))
+			    ,(match-call-args (cons (car patterns) same)
+					      0
+					      call-var
+					      fail-var
+					      more))
+			  res))))))))
+
+(define (finish-call-match clauses call-var primop-var fail-var)
+  (receive (elses other)
+      (partition-list (lambda (c)
+			(eq? (car c) 'else))
+		      clauses)
+    `(case (primop-id (call-primop ,call-var))
+       ,@(reverse other)
+       (else ,(cond ((null? elses)
+		     (if fail-var `(,fail-var) #f))
+		    ((null? (cdr elses))
+		     `(let ((,primop-var (call-primop ,call-var)))
+			,(cadar elses)))  ; strip of uneeded ELSE
+		    (else
+		     (error "more than one ELSE clause" elses)))))))
+
+; Similar to MATCH-CALLS, except that this is matching the I'th argument of a
+; call.  All patterns with similar I'th arguments are grouped together and
+; passed to MATCH-CALL-ARG.  The clauses that are returned are made into a
+; COND expression by FINISH-MATCH-CALL-ARGS.
+; If there are fewer than I arguments, MORE is called to continue matching
+; other parts of the patterns.
+; Patterns that always match the I'th argument are handled separately.
+; They are used to generate the ELSE clause of the conditional returned.
+; If there are no such patterns, then the passed-in FAIL-VAR is called
+; if no patterns match.
+
+(define (match-call-args patterns i call-var fail-var more)
+  (if (>= i (length (cdr (pattern-spec (car patterns)))))
+      (more patterns)
+      (receive (atom-patterns other-patterns)
+	  (partition-list (lambda (p)
+			    (atom? (pattern-arg p i)))
+			  patterns)
+	(let* ((arg-var (generate-symbol 'arg))
+	       (else-code (cond ((null? atom-patterns)
+				 #f)
+				(else
+				 (extend-pattern-envs atom-patterns i arg-var)
+				 (match-call-args atom-patterns (+ i 1)
+						  call-var fail-var more))))
+	       (fail-var (if else-code (generate-symbol 'fail) fail-var))
+	       (more (lambda (patterns)
+		       (match-call-args patterns (+ i 1)
+					call-var fail-var more))))
+	  (let loop ((patterns other-patterns) (clauses '()))
+	    (if (null? patterns)
+		(finish-match-call-args i call-var arg-var fail-var
+					else-code clauses)
+		(let ((first (car patterns)))
+		  (receive (same other)
+		      (partition-list (lambda (p)
+					(same-arg-pattern? first p i))
+				      (cdr patterns))
+		    (loop other
+			  (cons (match-call-arg (cons first same)
+						i
+						arg-var
+						fail-var
+						more)
+				clauses))))))))))
+
+; If ELSE-CODE exists this binds FAIL-VAR to a failure procedure containing it.
+; The CLAUSES are put in a COND.
+
+(define (finish-match-call-args i call-var arg-var fail-var else-code clauses)
+  `(let ((,arg-var (call-arg ,call-var ,i)))
+     ,(if else-code
+	  `(let ((,fail-var (lambda () ,else-code)))
+	     (cond ,@clauses (else (,fail-var))))
+	  `(cond ,@clauses (else ,(if fail-var `(,fail-var) #f))))))
+
+; Are the I'th arguments of patterns P1 and P2 the same as far as matching
+; arguments is concerned?
+
+(define (same-arg-pattern? p1 p2 i)
+  (let ((a1 (pattern-arg p1 i))
+	(a2 (pattern-arg p2 i)))
+    (cond ((atom? a1)
+	   (atom? a2))
+	  ((atom? a2)
+	   #f)
+	  ((eq? (car a1) 'quote)
+	   (eq? (car a2) 'quote))
+	  ((eq? (car a2) 'quote)
+	   #f)
+	  (else #t))))
+
+; Dispatch on the type of the I'th argument of PATTERNS (all of which have
+; similar I'th arguments) and generate the appropriate code.
+; ARG-VAR is the identifier that will be bound to the actual argument.
+; MORE is a procedure that generates code for the rest of the patterns.
+; Atoms always match and require that the environments of the patterns
+; be extended.
+; Code for literals and calls are generated by other procedures.
+
+(define (match-call-arg patterns i arg-var fail-var more)
+  (let ((arg (pattern-arg (car patterns) i)))
+    (cond ((eq? (car arg) 'quote)
+	   `((literal-node? ,arg-var)
+	     ,(match-literal patterns i arg-var fail-var more)))
+	  (else
+	   `((call-node? ,arg-var)
+	     ,(match-calls (map (lambda (p)
+				  (pattern-maker (pattern-arg p i)
+						 (pattern-env p)
+						 p
+						 (pattern-predicate p)
+						 (pattern-build-spec p)))
+				patterns)
+			   arg-var
+			   fail-var
+			   (lambda (patterns)
+			     (more (map get-pattern-parent patterns)))))))))
+
+; Again we sort the patterns into similar groups and build a clause for
+; each group.  Patterns with symbols have their environments extended.
+; FINISH-MATCH-LITERAL puts the clauses into a CASE expression.
+
+(define (match-literal patterns i arg-var fail-var more)
+  (receive (symbols numbers)
+      (partition-list (lambda (p)
+			(symbol? (cadr (pattern-arg p i))))
+		      patterns)
+    (extend-pattern-envs symbols i arg-var)
+    (if (null? numbers)
+	(more symbols)
+	(let loop ((patterns numbers) (clauses '()))
+	  (if (null? patterns)
+	      (finish-match-literal clauses
+				    (if (null? symbols)
+					(if fail-var `(,fail-var) #f)
+					(more symbols))
+				    arg-var)
+	      (receive (same other)
+		  (partition-list (lambda (p)
+				    (= (cadr (pattern-arg (car patterns) i))
+				       (cadr (pattern-arg p i))))
+				  (cdr patterns))
+		(loop other
+		      (cons `((,(cadr (pattern-arg (car patterns) i)))
+			      ,(more (cons (car patterns) same)))
+			    clauses))))))))
+
+(define (finish-match-literal clauses else arg-var)
+  (if (null? clauses)
+      else
+      `(case (literal-value ,arg-var)
+	 ,@(reverse clauses)
+	 (else ,else))))
+				   
+;------------------------------------------------------------------------------
+; GENSYM utility
+
+(define *generate-symbol-index* 0)
+
+(define (generate-symbol sym)
+  (let ((i *generate-symbol-index*))
+    (set! *generate-symbol-index* (+ i 1))
+    (concatenate-symbol sym "." i)))
+
+;------------------------------------------------------------------------------
+; Add code to check the predicate if any.
+
+(define (check-predicates patterns initial)
+  (let label ((patterns patterns))
+    (cond ((null? (cdr patterns))
+	   (let ((pattern (car patterns)))
+	     (if (pattern-predicate pattern)
+		 (make-predicate-check pattern initial #f)
+		 (make-builder pattern initial))))
+	  ((pattern-predicate (car patterns))
+	   (make-predicate-check (car patterns)
+				 initial
+				 (label (cdr patterns))))
+	  (else
+	   (error "multiple patterns matched ~S"
+		  patterns)))))
+
+(define (make-predicate-check pattern initial rest)
+  `(if (let ,(map (lambda (p)
+		    `(,(car p) ,(if (caddr p)
+				    `(literal-value ,(cadr p))
+				    (cadr p))))
+		  (pattern-env pattern))
+	 ,(pattern-predicate pattern))
+       ,(make-builder pattern initial)
+       ,rest))
+
+;------------------------------------------------------------------------------
+; Building the result of a pattern match
+; A new environment is made as the builder must keep track of how many times
+; each node in the matched pattern is used.
+; CLAUSES is a list of LET-NODES clauses for making the call nodes in the
+; produced pattern.  VALUE is what will replace the original pattern in the
+; node tree.  Any nodes that are used in the result are DETACHed.
+
+(define (make-builder pattern initial)
+  (let ((env (map (lambda (p)
+		    (list (car p) (cadr p) #f))
+		  (pattern-env pattern)))
+	(pattern (pattern-build-spec pattern))
+	(sym (generate-symbol 'result)))
+    (let ((clauses (if (and (pair? pattern)
+			    (neq? (car pattern) 'quote))
+		       (reverse (build-call sym pattern env))
+		       '()))
+	  (value (cond ((not (pair? pattern))
+			(lookup-pattern pattern env))
+		       ((eq? (car pattern) 'quote)
+			`(make-literal-node ,(build-literal (cadr pattern) env)
+					    (node-type ,initial)))
+		       (else
+			sym))))
+      `(begin
+	 ,@(filter-map (lambda (data)
+			 (if (caddr data)
+			     `(detach ,(cadr data))
+			     #f))
+		       env)
+	 (let-nodes ,clauses
+           (replace ,initial ,value))))))
+
+; Go down the arguments in PATTERN making the appropriate LET-NODES spec
+; for each.
+
+(define (build-call id pattern env)
+  (let loop ((arg-patterns (cdr pattern)) (args '()) (clauses '()))
+    (if (null? arg-patterns)
+	`((,id (,(car pattern) 0 . ,(reverse args)))
+	  . ,clauses)
+	(let ((arg (car arg-patterns)))
+	  (cond ((atom? arg)
+		 (loop (cdr arg-patterns)
+		       (cons (lookup-pattern arg env) args)
+		       clauses))
+		((eq? (car arg) 'quote)
+		 (loop (cdr arg-patterns)
+		       (cons `'(,(build-literal (cadr arg) env)
+				type/unknown)
+			     args)
+		       clauses))
+		(else
+		 (let ((sym (generate-symbol 'new)))
+		   (loop (cdr arg-patterns)
+			 (cons sym args)
+			 (append (build-call sym arg env) clauses)))))))))
+
+; A literal specification is either a number, a symbol which will bound to a
+; number, or an expression to be evaluated.
+
+(define (build-literal spec env)
+  (cond ((number? spec)
+	 spec)
+	((symbol? spec)
+	 `(literal-value ,(lookup-literal spec env)))
+	(else
+	 `(,(car spec)
+	   . ,(map (lambda (a)
+		     (build-literal a env))
+		   (cdr spec))))))
+
+; Get the identifier that will be bound to the value of PATTERN.
+
+(define (lookup-literal pattern env)
+  (cond ((assoc pattern env)
+	 => cadr)
+	(else
+	 (error "pattern ~S not found in env" pattern))))
+
+; Get the identifier that will be bound to the node value of PATTERN.
+; Annotate the environment to mark that the node has been used.
+
+(define (lookup-pattern pattern env)
+  (cond ((assoc pattern env)
+	 => (lambda (data)
+	      (if (caddr data)
+		  (error "node ~S is used more than once" (car data)))
+	      (set-car! (cddr data) 1)
+	      (cadr data)))
+	(else
+	 (error "pattern ~S not found in env" pattern))))
+
+
+
diff --git a/ps-compiler/simp/simplify.scm b/ps-compiler/simp/simplify.scm
new file mode 100644
index 0000000..f4c11d6
--- /dev/null
+++ b/ps-compiler/simp/simplify.scm
@@ -0,0 +1,93 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+;   Post-CPS optimizer.  All simplifications are done by changing the
+; structure of the node tree.
+;
+; There are two requirements for the simplifiers:
+;    1) Only the node being simplified and its descendents may be changed.
+;    2) If a node is changed the NODE-SIMPLIFIED? flag of that node and all
+;       its ancestors must be set to false.
+
+; No way to simplify literal or reference nodes.
+
+(define (simplify-node node)
+  (cond ((call-node? node)
+	 (simplify-call node))
+	((lambda-node? node)
+	 (simplify-lambda-body node))))
+
+(define (simplify-global-reference ref)
+  (let ((value (variable-known-value (reference-variable ref))))
+    (if value
+	(replace ref (vector->node value)))))
+
+(define (simplify-lambda-body lambda-node)
+  (let loop ()
+    (let ((node (lambda-body lambda-node)))
+      (cond ((not (node-simplified? node))
+	     (set-node-simplified?! node #t)
+             (simplify-call node)
+             (loop))))))
+
+(define (default-simplifier call)
+  (simplify-args call 0))
+
+; Utility used by many simplifiers - simplify the specified children.
+
+(define (simplify-args call start)
+  (let* ((vec (call-args call))
+         (len (vector-length vec)))
+    (do ((i start (+ i '1)))
+        ((>= i len))
+      (really-simplify-arg vec i))))
+
+; Keep simplifying a node until it stops changing.
+
+(define (simplify-arg call index)
+  (really-simplify-arg (call-args call) index))
+
+(define (really-simplify-arg vec index)
+  (let loop ((node (vector-ref vec index)))
+    (cond ((not (node-simplified? node))
+	   (set-node-simplified?! node #t)
+	   (case (node-variant node)
+	     ((reference)
+	      (if (global-variable? (reference-variable node))
+		  (simplify-global-reference node)))
+	     ((call)
+	      (simplify-call node))
+	     ((lambda)
+	      (simplify-lambda-body node)))
+	   (loop (vector-ref vec index))))))
+
+; Remove any unused arguments to L-NODE
+; Could substitute identical arguments as well...
+
+(define (simplify-known-lambda l-node)
+  (let ((unused (filter (lambda (var) (not (used? var)))
+			(if (eq? 'proc (lambda-type l-node))
+			    (cdr (lambda-variables l-node))
+			    (lambda-variables l-node)))))
+    (if (not (null? unused))
+	(let ((refs (find-calls l-node)))
+	  (for-each (lambda (var)
+		      (let ((index (+ 1 (variable-index var))))
+			(for-each (lambda (ref)
+				    (remove-ith-argument (node-parent ref)
+							 index
+							 var))
+				  refs)
+			(remove-variable l-node var)))
+		    unused)))))
+    
+; VAR is used to get the appropriate representation
+
+(define (remove-ith-argument call index var)
+  (let ((value (detach (call-arg call index))))
+    (remove-call-arg call index)
+    (move-body call
+	       (lambda (call)
+		 (let-nodes ((c1 (let 1 l1 value))
+			     (l1 (var) call))
+		   c1)))))
diff --git a/ps-compiler/util/byte-vector.scm b/ps-compiler/util/byte-vector.scm
new file mode 100644
index 0000000..247628f
--- /dev/null
+++ b/ps-compiler/util/byte-vector.scm
@@ -0,0 +1,93 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+; byte vectors are just code vectors
+
+(define make-byte-vector   make-code-vector)
+(define byte-vector?       code-vector?)
+(define byte-vector-length code-vector-length)
+
+(define byte-vector-ref  code-vector-ref)
+(define byte-vector-set! code-vector-set!)
+
+(define (byte-vector-endianess)
+  (if (eq? byte-vector-word-ref high-byte-vector-word-ref)
+      'high
+      'low))
+
+(define (set-byte-vector-endianess! high-or-low)
+  (case high-or-low
+    ((high)
+     (set! byte-vector-word-ref       high-byte-vector-word-ref)
+     (set! byte-vector-half-word-ref  high-byte-vector-half-word-ref)
+     (set! byte-vector-word-set!      high-byte-vector-word-set!)
+     (set! byte-vector-half-word-set! high-byte-vector-half-word-set!))
+    ((low)
+     (set! byte-vector-word-ref       low-byte-vector-word-ref)
+     (set! byte-vector-half-word-ref  low-byte-vector-half-word-ref)
+     (set! byte-vector-word-set!      low-byte-vector-word-set!)
+     (set! byte-vector-half-word-set! low-byte-vector-half-word-set!))
+    (else
+     (error "endianess specifier is neither HIGH nor LOW" high-or-low))))
+
+(define (high-byte-vector-word-ref vector index)
+  (+ (code-vector-ref vector (+ index 3))
+     (arithmetic-shift
+      (+ (code-vector-ref vector (+ index 2))
+	 (arithmetic-shift
+	  (+ (code-vector-ref vector (+ index 1))
+	     (arithmetic-shift
+	      (code-vector-ref vector index)
+	      8))
+	  8))
+      8)))
+
+(define (high-byte-vector-word-set! vector index value)
+  (byte-vector-set! vector index       (arithmetic-shift value -24))
+  (byte-vector-set! vector (+ index 1) (arithmetic-shift value -16))
+  (byte-vector-set! vector (+ index 2) (arithmetic-shift value -8))
+  (byte-vector-set! vector (+ index 3)                   value))
+
+(define (high-byte-vector-half-word-ref vector index)
+  (+ (code-vector-ref vector (+ index 1))
+     (arithmetic-shift
+      (code-vector-ref vector index)
+      8)))
+
+(define (high-byte-vector-half-word-set! vector index value)
+  (byte-vector-set! vector index       (arithmetic-shift value -8))
+  (byte-vector-set! vector (+ index 1)                   value))
+
+(define (low-byte-vector-word-ref vector index)
+  (+ (code-vector-ref vector index)
+     (arithmetic-shift
+      (+ (code-vector-ref vector (+ index 1))
+	 (arithmetic-shift
+	  (+ (code-vector-ref vector (+ index 2))
+	     (arithmetic-shift
+	      (code-vector-ref vector (+ index 3))
+	      8))
+	  8))
+      8)))
+
+(define (low-byte-vector-word-set! vector index value)
+  (byte-vector-set! vector index                         value)
+  (byte-vector-set! vector (+ index 1) (arithmetic-shift value -8))
+  (byte-vector-set! vector (+ index 2) (arithmetic-shift value -16))
+  (byte-vector-set! vector (+ index 3) (arithmetic-shift value -24)))
+
+(define (low-byte-vector-half-word-ref vector index)
+  (+ (code-vector-ref vector index)
+     (arithmetic-shift
+      (code-vector-ref vector (+ index 1))
+      8)))
+
+(define (low-byte-vector-half-word-set! vector index value)
+  (byte-vector-set! vector index                         value)
+  (byte-vector-set! vector (+ index 1) (arithmetic-shift value -8)))
+
+; Start high-endian
+(define byte-vector-word-ref       high-byte-vector-word-ref)
+(define byte-vector-half-word-ref  high-byte-vector-half-word-ref)
+(define byte-vector-word-set!      high-byte-vector-word-set!)
+(define byte-vector-half-word-set! high-byte-vector-half-word-set!)
diff --git a/ps-compiler/util/dominators.scm b/ps-compiler/util/dominators.scm
new file mode 100644
index 0000000..1eea4b2
--- /dev/null
+++ b/ps-compiler/util/dominators.scm
@@ -0,0 +1,273 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+;;; Find immediate dominators in a directed graph
+;;; Mark Reinhold (mbr@research.nj.nec.com)/3 February 1995
+; Debugging code removed and everything reluctantly Scheme-ized by
+; R. Kelsey, St. Valentine's Day, 1995
+
+; This fast dominator code is based upon Lengauer and Tarjan, "A Fast
+; Algorithm for Finding Dominators in a Flowgraph," ACM TOPLAS 1:1, pp.
+; 121--141, July 1979.  It runs in time $O(|E|\log|V|)$, where $|E|$ is the
+; number of edges and $|V|$ is the number of vertices.  A smaller time bound
+; of $O(|E|\alpha(|E|,|V|))$, where $\alpha$ is the inverse of Ackerman's
+; function, can be achieved with more complex versions of the internal link!
+; and eval! procedures.
+;
+; The client provides a rooted, directed graph by passing a root node,
+; successor and predecessor functions, and auxiliary procedures for accessing
+; and setting a slot in each node.  The dominator code creates a shadow of
+; the client's graph using the vertex record type defined below.  To keep
+; things clear, the client's graph is considered to contain "nodes," while
+; the shadow graph contains "vertices."
+
+(define-record-type vertex :vertex
+  (really-make-vertex node semi bucket ancestor debug)
+  vertex?
+  (node vertex-node)        ; Corresponding node in client's graph
+  (semi vertex-semi         ; A number for this vertex, w, as follows:
+	set-vertex-semi!)   ;   After w is numbered, but before its semidominator
+			    ;      is computed: w's DFS number
+		            ;   After w's semidominator is computed:
+		            ;      the number of its semidominator
+  (parent vertex-parent     ; Parent of this vertex in DFS spanning tree
+	  set-vertex-parent!)
+  (pred vertex-pred         ; Parents
+	set-vertex-pred!)
+  (label vertex-label       ; Label in spanning forest, initially this vertex
+	 set-vertex-label!)
+  (bucket vertex-bucket     ; List of vertices whose semidominator is this vertex
+	  set-vertex-bucket!)
+  (dom vertex-dom           ; A vertex, as follows:
+       set-vertex-dom!)     ;   After step 3: If the semidominator of this
+    		            ;      vertex, w, is its immediate dominator, then
+		            ;      this slot contains that vertex; otherwise,
+		            ;      this slot is a vertex v whose number is
+		            ;      smaller than w's and whose immediate dominator
+                            ;      is also w's immediate dominator
+		            ;   After step 4: The immediate dominator of this
+                            ;      vertex
+  (ancestor vertex-ancestor ; An ancestor of this vertex in the spanning forest
+	    set-vertex-ancestor!)
+  (debug vertex-debug       ; Debug field ##
+	 set-vertex-debug!))
+
+(define (make-vertex node semi)
+  (really-make-vertex node
+		      semi
+		      '()	; bucket
+		      #f	; ancestor
+		      #f))	; debug
+
+(define (push-vertex-bucket! inf elt)
+  (set-vertex-bucket! inf (cons elt (vertex-bucket inf))))
+
+
+(define (find-dominators-quickly! root		; root node
+				  succ		; maps a node to its children
+				  pred		; maps a node to its parents
+				  slot		; result slot accessor
+				  set-slot!)	; result slot setter
+  ;; Compute the dominator tree of the given rooted, directed graph;
+  ;; when done, the slot of each node will contain its immediate dominator.
+  ;; Requires that each slot initially contain #f.
+
+  (define (dfs root)
+    (let ((n 0) (vertices '()))
+      (let go ((node root) (parent #f))
+	(let ((v (make-vertex node n)))
+	  (set-slot! node v)
+	  (set! n (+ n 1))
+	  (set-vertex-parent! v parent)
+	  (set-vertex-label! v v)
+	  (set! vertices (cons v vertices))
+	  (for-each (lambda (node)
+		      (if (not (slot node))
+			  (go node v)))
+		    (succ node))))
+      
+      (let ((vertex-map (list->vector (reverse! vertices))))
+	(do ((i 0 (+ i 1)))
+	    ((= i (vector-length vertex-map)))
+	  (let ((v (vector-ref vertex-map i)))
+	    (set-vertex-pred! v (map slot (pred (vertex-node v))))))
+	(values n vertex-map))))
+
+  (define (compress! v)
+    (let ((a (vertex-ancestor v)))
+      (if (vertex-ancestor a)
+	  (begin
+	    (compress! a)
+	    (if (< (vertex-semi (vertex-label a))
+		   (vertex-semi (vertex-label v)))
+		(set-vertex-label! v (vertex-label a)))
+	    (set-vertex-ancestor! v (vertex-ancestor (vertex-ancestor v)))))))
+    
+  (define (eval! v)
+    (cond ((not (vertex-ancestor v))
+	   v)
+	  (else
+	   (compress! v)
+	   (vertex-label v))))
+  
+  (define (link! v w)
+    (set-vertex-ancestor! w v))
+  
+  (receive (n vertex-map) (dfs root)	; Step 1
+    (do ((i (- n 1) (- i 1)))
+	((= i 0))
+      (let ((w (vector-ref vertex-map i)))
+	
+	(for-each (lambda (v)		; Step 2
+		    (let ((u (eval! v)))
+		      (if (< (vertex-semi u)
+			     (vertex-semi w))
+			  (set-vertex-semi! w
+					    (vertex-semi u)))))
+		  (vertex-pred w))
+	(push-vertex-bucket! (vector-ref vertex-map (vertex-semi w)) w)
+	(link! (vertex-parent w) w)
+	
+	(for-each (lambda (v)		; Step 3
+		    ;; T&L delete v from the bucket list at this point,
+		    ;; but there is no reason to do so
+		    (let ((u (eval! v)))
+		      (set-vertex-dom! v
+				       (if (< (vertex-semi u)
+					      (vertex-semi v))
+					   u
+					   (vertex-parent w)))))
+		  (vertex-bucket (vertex-parent w)))))
+    
+    (do ((i 1 (+ i 1)))			; Step 4
+	((= i n))
+      (let ((w (vector-ref vertex-map i)))
+	(if (not (eq? (vertex-dom w)
+		      (vector-ref vertex-map (vertex-semi w))))
+	    (set-vertex-dom! w
+			     (vertex-dom (vertex-dom w))))))
+    (set-vertex-dom! (slot root) #f)
+    
+    ;(show-nodes root succ slot)	; ## debug
+    
+    (do ((i 0 (+ i 1)))			; Set dominator pointers
+	((= i n))
+      (let ((w (vector-ref vertex-map i)))
+	(let ((d (vertex-dom w)))
+	  (set-slot! (vertex-node w) (if d (vertex-node d) #f)))))))
+
+
+;;; The fast dominator algorithm is difficult to prove correct, so the
+;;; following slow code is provided in order to check its results.  The slow
+;;; algorithm, which runs in time $O(|E||V|)$, is adapted from Aho and Ullman,
+;;; _The Theory of Parsing, Translation, and Compiling_, Prentice-Hall, 1973,
+;;; p. 916.
+
+
+(define (find-dominators-slowly! root succ pred slot set-slot!)
+
+  (define vertex-succ vertex-pred)
+  (define set-vertex-succ! set-vertex-pred!)
+  (define vertex-mark vertex-ancestor)
+  (define set-vertex-mark! set-vertex-ancestor!)
+
+  (define (dfs root)
+    (let ((n 0) (vertices '()))
+      (let go ((node root) (parent #f))
+	(let ((v (make-vertex node n)))
+	  (set-slot! node v)
+	  (set! n (+ n 1))
+	  (set! vertices (cons v vertices))
+	  (set-vertex-parent! v #f)
+	  (set-vertex-label! v #f)
+	  (for-each (lambda (node)
+		      (if (not (slot node))
+			  (go node v)))
+		    (succ node))))
+
+      (for-each (lambda (v)
+		  (set-vertex-succ! v (map slot (succ (vertex-node v)))))
+		vertices)
+      (values n (reverse! vertices))))
+
+  (receive (n vertices) (dfs root)
+
+    (define (inaccessible v)
+      ;; Determine set of vertices that are inaccessible if vertex v is ignored
+      (set-vertex-mark! v #t)
+      (let go ((w (car vertices)))
+	(set-vertex-mark! w #t)
+	(for-each (lambda (u)
+		    (if (not (vertex-mark u))
+			(go u)))
+		  (vertex-succ w)))
+      (filter (lambda (w)
+		(cond
+		 ((vertex-mark w)
+		  (set-vertex-mark! w #f)
+		  #f)
+		 (else #t)))
+	      vertices))
+
+    (for-each (lambda (v) (set-vertex-dom! v (car vertices)))
+	      (cdr vertices))
+
+    (for-each (lambda (v)
+		(let ((dominated-by-v (inaccessible v)))
+		  (for-each (lambda (w)
+			      (if (eq? (vertex-dom w) (vertex-dom v))
+				  (set-vertex-dom! w v)))
+			    dominated-by-v)))
+	      (cdr vertices))
+    (set-vertex-dom! (car vertices) #f)
+
+					;(show-nodes root succ slot)	; ## debug
+
+    (for-each (lambda (v)
+		(set-slot! (vertex-node v)
+			   (let ((d (vertex-dom v)))
+			     (if d (vertex-node d) #f))))
+	      vertices)))
+
+
+(define (time-thunk thunk) (thunk))
+
+(define (find-and-check-dominators! root succ pred slot set-slot!)
+  (let ((set-fast-slot! (lambda (x v) (set-car! (slot x) v)))
+	(fast-slot (lambda (x) (car (slot x))))
+	(set-slow-slot! (lambda (x v) (set-cdr! (slot x) v)))
+	(slow-slot (lambda (x) (cdr (slot x)))))
+
+    (let go ((node root))
+      (set-slot! node (cons #f #f))
+      (for-each (lambda (node)
+		  (if (not (slot node))
+		      (go node)))
+		(succ node)))
+
+    (let ((fast (time-thunk
+		 (lambda ()
+		   (find-dominators-quickly!
+		    root succ pred fast-slot set-fast-slot!))))
+	  (slow (time-thunk (lambda ()
+			      (find-dominators-slowly!
+			       root succ pred slow-slot set-slow-slot!)))))
+
+					;     (format #t "** find-and-check-dominators!: fast ~a, slow ~a~%" fast slow)	; ##
+      (let go ((node root))
+	(if (not (eq? (fast-slot node) (slow-slot node)))
+	    (bug "Dominator algorithm error"))
+	(set-slot! node (fast-slot node))
+	(for-each (lambda (node)
+		    (if (pair? (slot node)) ; ## Assumes nodes are not pairs
+			(go node)))
+		  (succ node))))))
+
+
+(define *check?* #t)
+
+(define (find-dominators! . args)
+  (apply (if *check?*
+	     find-and-check-dominators!
+	     find-dominators-quickly!)
+	 args))
+
diff --git a/ps-compiler/util/expand-vec.scm b/ps-compiler/util/expand-vec.scm
new file mode 100644
index 0000000..dfe2e84
--- /dev/null
+++ b/ps-compiler/util/expand-vec.scm
@@ -0,0 +1,124 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+; Vectors of infinite length.  These work as do regular vectors except that
+; they have no fixed size.  XVECTOR-LENGTH is one more than the highest index
+; that has been passed to XVECTOR-SET!.
+;
+; (MAKE-XVECTOR <fill>)
+; (XVECTOR-LENGTH <xvec>)
+; (XVECTOR-REF <xvec> <index>)
+; (XVECTOR-SET! <xvec> <index> <value>)
+; (XVECTOR->VECTOR <xvec>)
+
+; The actual record fields are:
+;  default  - the fill value
+;  length   - total length of internal vector(s)
+;  contents - either:
+;      a: vector of entries, or
+;      b: vector of vectors of entries, vector has #f's after the last needed
+;         sub-vector, each sub-vector has length XVEC-MAX-CONTENTS-SIZE
+;  max      - maximum index used in a XVECTOR-SET!
+
+
+(define-record-type expanding-vector :expanding-vector
+  (make-expanding-vector default length contents max)
+  expanding-vector?
+  (default expanding-vector-default)
+  (length expanding-vector-length set-expanding-vector-length!)
+  (contents expanding-vector-contents set-expanding-vector-contents!)
+  (max expanding-vector-max set-expanding-vector-max!))
+
+(define (make-xvector default)
+  (make-expanding-vector default 0 '#() -1))
+
+; Maximum size of any internal vector
+
+(define xvec-max-contents-size 1024)
+
+; XVECTOR-LENGTH returns 1 + the maximum index passed to XVECTOR-SET!
+
+(define (xvector-length xvec)
+  (+ 1 (expanding-vector-max xvec)))
+
+; If INDEX points outside current storage, the default is returned, otherwise
+; the value is extracted from the one-or-two-level contents vector.
+
+(define (xvector-ref xvec index)
+  (let ((length (expanding-vector-length xvec)))
+    (cond ((>= index length)
+	   (expanding-vector-default xvec))
+	  ((<= length xvec-max-contents-size)
+	   (vector-ref (expanding-vector-contents xvec) index))
+	  (else
+	   (vector-ref (vector-ref (expanding-vector-contents xvec)
+				   (quotient index xvec-max-contents-size))
+		       (remainder index xvec-max-contents-size))))))
+
+; Same as the above, setting instead of extracting.  INDEX is checked agains
+; the maximum index, and the contents may have to be expanded.
+
+(define (xvector-set! xvec index value)
+  (let ((length (expanding-vector-length xvec)))
+    (if (> index (expanding-vector-max xvec))
+	(set-expanding-vector-max! xvec index))
+    (cond ((>= index length)
+	   (expand-expanding-vector xvec)
+	   (xvector-set! xvec index value))
+	  ((<= length xvec-max-contents-size)
+	   (vector-set! (expanding-vector-contents xvec) index value))
+	  (else
+	   (vector-set! (vector-ref (expanding-vector-contents xvec)
+				    (quotient index xvec-max-contents-size))
+			(remainder index xvec-max-contents-size)
+			value)))))
+
+; Copy an expanding vector into a regular vector.
+
+(define (xvector->vector xvec)
+  (let ((new (make-vector (xvector-length xvec))))
+    (do ((i 0 (+ i 1)))
+        ((>= i (xvector-length xvec)))
+      (vector-set! new i (xvector-ref xvec i)))
+    new))
+
+; Expand an expanding vector.  A new length and contents are produced and
+; put in XVEC.  If LENGTH is below the maximum for a contents vector it is
+; doubled in size.  If the two-level structure is being used, a new sub-
+; vector is added to it.
+
+(define (expand-expanding-vector xvec)
+  (let ((length   (expanding-vector-length   xvec))
+	(contents (expanding-vector-contents xvec))
+	(default  (expanding-vector-default  xvec))
+	(finish (lambda (length contents)
+		  (set-expanding-vector-length!   xvec length)
+		  (set-expanding-vector-contents! xvec contents))))
+    (if (< length xvec-max-contents-size)
+	(let ((new (expand-vector contents default)))
+	  (finish (vector-length new) new))
+	(let ((contents (cond ((= length xvec-max-contents-size)
+			       (let ((new (make-vector 4 #f)))
+				 (vector-set! new 0 contents)
+				 new))
+			      ((vector-ref contents
+					   (- (vector-length contents) 1))
+			       (expand-vector contents #f))
+			      (else
+			       contents))))
+	  (vector-set! contents
+		       (quotient length xvec-max-contents-size)
+		       (make-vector xvec-max-contents-size default))
+	  (finish (+ length xvec-max-contents-size) contents)))))
+
+; Make a new vector twice the length of OLD and copy the contents of OLD into
+; it.  DEFAULT is used to fill in the other slots.
+
+(define (expand-vector old default)
+  (let* ((length (vector-length old))
+	 (new (make-vector (if (= 0 length) 4 (* 2 length)) default)))
+    (do ((i 0 (+ i 1)))
+	((>= i length))
+      (vector-set! new i (vector-ref old i)))
+    new))
+	  
\ No newline at end of file
diff --git a/ps-compiler/util/separators.scm b/ps-compiler/util/separators.scm
new file mode 100644
index 0000000..84f4827
--- /dev/null
+++ b/ps-compiler/util/separators.scm
@@ -0,0 +1,195 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+; Code to determine the separation vertices of a graph
+
+; NODES is a list of nodes
+; (TO node) returns a list of the nodes which are connected to this one
+; (SLOT-NODE node) and (SET-SLOT! node value) are used by the algorithm to
+; associate data with nodes (in the absence of a tables).
+
+(define (separation-vertices nodes to slot set-slot!)
+  (cond ((null? nodes)
+	 (values '() '()))
+	((null? (cdr nodes))
+	 (values nodes (list nodes)))
+	(else
+	 (receive (separators components)
+	     (real-separation-vertices (make-vertices nodes to slot set-slot!))
+	   (for-each (lambda (n) (set-slot! n #f)) nodes)
+	   (values separators components)))))
+
+(define-record-type vertex :vertex
+  (really-make-vertex data edges dfs-index)
+  vertex?
+  (data vertex-data)                  ; user's data
+  (edges vertex-edges                 ; list of edges from this vertex
+	 set-vertex-edges!)    
+  (dfs-index vertex-dfs-index         ; ordering from depth-first-search
+	     set-vertex-dfs-index!)    
+  (level vertex-level                 ; value used in algorithm...
+	 set-vertex-level!)
+  (parent vertex-parent               ; parent of this node in DFS tree
+	  set-vertex-parent!))
+
+(define (make-vertex data)
+  (really-make-vertex data '() 0))
+
+(define-record-type edge :edge
+  (make-edge from to unused?)
+  (from edge-from)             ; two (unordered) vertices
+  (to edge-to)
+  (unused? edge-unused         ; used to mark edges that have been traversed
+	   set-edge-unused!))
+
+(define (make-edge from to)
+  (really-make-edge from to #t))
+
+(define (other-vertex edge v)
+  (if (eq? v (edge-from edge))
+      (edge-to edge)
+      (edge-from edge)))
+
+(define (maybe-add-edge from to)
+  (if (and (not (eq? from to))
+	   (not (any? (lambda (e)
+			(or (eq? to (edge-from e))
+			    (eq? to (edge-to e))))
+		      (vertex-edges from))))
+      (let ((e (make-edge from to)))
+	(set-vertex-edges! from (cons e (vertex-edges from)))
+	(set-vertex-edges! to   (cons e (vertex-edges to))))))
+
+(define (make-vertices nodes to slot set-slot!)
+  (let ((vertices (map (lambda (n)
+			 (let ((v (make-vertex n)))
+			   (set-slot! n v)
+			   v))
+		       nodes)))
+    (for-each (lambda (n)
+		(for-each (lambda (n0)
+			    (maybe-add-edge (slot n) (slot n0)))
+			  (to n)))
+	      nodes)
+    vertices))
+    
+; The numbers are the algorithm step numbers from page 62 of Graph Algorithms,
+; Shimon Even, Computer Science Press, 1979.
+; Them           Us
+;  L(v)     (vertex-level v)
+;  k(v)     (vertex-dfs-index v)
+;  f(v)     (vertex-parent v)
+;  S        stack
+;  s        start
+
+(define (real-separation-vertices vertices)
+  (do-vertex (car vertices) 0 '() (car vertices) '() '()))
+
+; 2
+
+(define (do-vertex v i stack start v-res c-res)
+  (let ((i (+ i 1)))
+    (set-vertex-level! v i)
+    (set-vertex-dfs-index! v i)
+    (find-unused-edge v i (cons v stack) start v-res c-res)))
+
+; 3
+
+(define (find-unused-edge v i stack start v-res c-res)
+  (let ((e (first edge-unused? (vertex-edges v))))
+    (if e
+	(do-edge e v i stack start v-res c-res)
+	(no-unused-edge v i stack start v-res c-res))))
+
+; 4
+
+(define (do-edge e v i stack start v-res c-res)
+  (let ((u (other-vertex e v)))
+    (set-edge-unused?! e #f)
+    (cond ((= 0 (vertex-dfs-index u))
+	   (set-vertex-parent! u v)
+	   (do-vertex u i stack start v-res c-res))
+	  (else
+	   (if (> (vertex-level v)
+		  (vertex-dfs-index u))
+	       (set-vertex-level! v (vertex-dfs-index u)))
+	   (find-unused-edge v i stack start v-res c-res)))))
+
+; 5
+
+(define (no-unused-edge v i stack start v-res c-res)
+  (let* ((parent (vertex-parent v))
+	 (p-dfs-index (vertex-dfs-index parent)))
+    (cond ((= 1 p-dfs-index)
+	   (gather-nonseparable-with-start v i stack start v-res c-res))
+	  ((< (vertex-level v) p-dfs-index)
+	   (if (< (vertex-level v)
+		  (vertex-level parent))
+	       (set-vertex-level! parent (vertex-level v)))
+	   (find-unused-edge parent i stack start v-res c-res))
+	  (else
+	   (gather-nonseparable v i stack start v-res c-res)))))
+
+; 7
+
+(define (gather-nonseparable v i stack start v-res c-res)
+  (let* ((parent (vertex-parent v))
+	 (data (vertex-data parent)))
+    (receive (vertices stack)
+	(pop-down-to stack v)
+      (find-unused-edge parent
+			i
+			stack
+			start
+			(if (not (memq? data v-res))
+			    (cons data v-res)
+			    v-res)
+			(cons (cons data (map vertex-data vertices)) c-res)))))
+
+; 9
+
+(define (gather-nonseparable-with-start v i stack start v-res c-res)
+  (receive (vertices stack)
+      (pop-down-to stack v)
+    (let* ((data (vertex-data start))
+	   (c-res (cons (cons data (map vertex-data vertices)) c-res)))
+      (if (not (any? edge-unused? (vertex-edges start)))
+	  (values v-res c-res)
+	  (find-unused-edge start
+			    i
+			    stack
+			    start
+			    (if (not (memq? data v-res))
+				(cons data v-res)
+				v-res)
+			    c-res)))))
+
+(define (pop-down-to stack v)
+  (do ((stack stack (cdr stack))
+       (res '() (cons (car stack) res)))
+      ((eq? v (car stack))
+       (values (cons v res) (cdr stack)))))
+
+(define (test-separation-vertices graph)
+  (let ((nodes (map (lambda (n)
+		      (vector (car n) #f #f))
+		    graph)))
+    (for-each (lambda (data node)
+		(vector-set! node 1 (map (lambda (s)
+					   (first (lambda (v)
+						    (eq? s (vector-ref v 0)))
+						  nodes))
+					 (cdr data))))
+	      graph
+	      nodes)
+    (receive (separation-vertices components)
+	(separation-vertices nodes
+			     (lambda (v) (vector-ref v 1))
+			     (lambda (v) (vector-ref v 2))
+			     (lambda (v val) (vector-set! v 2 val)))
+      (values (map (lambda (v) (vector-ref v 0)) separation-vertices)
+	      (map (lambda (l)
+		     (map (lambda (v) (vector-ref v 0))
+			  l))
+		   components)))))
+			   
diff --git a/ps-compiler/util/ssa.scm b/ps-compiler/util/ssa.scm
new file mode 100644
index 0000000..c3c5b5c
--- /dev/null
+++ b/ps-compiler/util/ssa.scm
@@ -0,0 +1,177 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+; Finding where to put phi-functions.
+;
+; First call:
+; (GRAPH->SSA-GRAPH! <root-node> <node-successors> <node-temp> <set-node-temp!>)
+;
+; Then:
+; (FIND-JOINS <nodes> <node-temp>)
+;  will return the list of nodes N for which there are (at least) two paths
+;  ... N_0 M_0 ... M_i N and ... N_1 P_0 ... P_j N such that N_0 and N_1
+;  are distinct members of <nodes> and the M's and P's are disjoint sets.
+;
+; Algorithm from:
+;   Efficiently computing static single assignment form and the control
+;     dependence graph,
+;   Ron Cytron, Jeanne Ferrante, Barry K. Rosen, Mark N. Wegman, and
+;     F. Kenneth Zadeck,
+;   ACM Transactions on Programming Languages and Systems 1991 13(4)
+;   pages 451-490
+
+(define-record-type node :node
+  (really-make-node data use-uid predecessors dominator dominated
+		    seen-mark join-mark)
+  node?
+  (data node-data)                ; user's stuff
+  (use-uid node-use-uid)          ; distinguishes between different invocations
+  (successors node-successors     ; parents
+	      set-node-successors!)
+  (predecessors node-predecessors ;  and children in the graph
+		set-node-predecessors!)
+  (dominator node-dominator       ; parent ;; initialize for goofy dominator code
+	     set-node-dominator!)
+  (dominated node-dominated       ;   and children in the dominator tree
+	     set-node-dominated!)
+  (frontier node-frontier         ; dominator frontier
+	    set-node-frontier!)
+  (seen-mark node-seen-mark       ; two markers used in
+	     set-node-seen-mark!)
+  (join-mark node-join-mark       ;  the ssa algorithm
+	     set-node-join-mark!))
+
+(define (make-node data use-uid)
+  (really-make-node data
+		    use-uid
+		    '()       ; predecessors
+		    #f        ; dominator
+		    '()       ; dominated
+		    -1        ; see-mark
+		    -1))      ; join-mark
+
+(define (graph->ssa-graph! root successors temp set-temp!)
+  (let ((graph (real-graph->ssa-graph root successors temp set-temp!)))
+    (find-dominators! (car graph)
+		      node-successors node-predecessors
+		      node-dominator set-node-dominator!)
+    (for-each (lambda (node)
+		(let ((dom (node-dominator node)))
+		  (set-node-dominated! dom (cons node (node-dominated dom)))))
+	      (cdr graph))   ; root has no dominator
+    (find-frontiers! (car graph))
+    (values)))
+
+; Turn the user's graph into a NODE graph.
+
+(define (real-graph->ssa-graph root successors temp set-temp!)
+  (let ((uid (next-uid))
+	(nodes '()))
+    (let recur ((data root))
+      (let ((node (temp data)))
+	(if (and (node? node)
+		 (= uid (node-use-uid node)))
+	    node
+	    (let ((node (make-node data uid)))
+	      (set! nodes (cons node nodes))
+	      (set-temp! data node)
+	      (let ((succs (map recur (successors data))))
+		(for-each (lambda (succ)
+			    (set-node-predecessors! succ
+						    (cons node (node-predecessors succ))))
+			  succs)
+		(set-node-successors! node succs))
+	      node))))
+    (reverse! nodes)))  ; root ends up at front
+
+; Find the dominance frontiers of the nodes in a graph.
+
+(define (find-frontiers! node)
+  (let ((frontier (let loop ((succs (node-successors node)) (frontier '()))
+               (if (null? succs)
+                   frontier
+                        (loop (cdr succs)
+                             (if (eq? node (node-dominator (car succs)))
+                                 frontier
+                                (cons (car succs) frontier)))))))
+    (let loop ((kids (node-dominated node)) (frontier frontier))
+      (cond ((null? kids)
+         (set-node-frontier! node frontier)
+      frontier)
+      (else
+            (let kid-loop ((kid-frontier (find-frontiers! (car kids)))
+                      (frontier frontier))
+               (if (null? kid-frontier)
+            (loop (cdr kids) frontier)
+              (kid-loop (cdr kid-frontier)
+                      (if (eq? node (node-dominator (car kid-frontier)))
+                          frontier
+                                (cons (car kid-frontier) frontier))))))))))
+
+(define (find-joins nodes temp)
+  (map node-data (really-find-joins (map temp nodes))))
+
+(define (really-find-joins nodes)
+  (let ((marker (next-uid)))
+    (for-each (lambda (n)
+		(set-node-seen-mark! n marker))
+	      nodes)
+    (let loop ((to-do nodes) (joins '()))
+      (if (null? to-do)
+	  joins
+	  (let frontier-loop ((frontier (node-frontier (car to-do)))
+			      (to-do (cdr to-do))
+			      (joins joins))
+	    (cond ((null? frontier)
+		   (loop to-do joins))
+		  ((eq? marker (node-join-mark (car frontier)))
+		   (frontier-loop (cdr frontier) to-do joins))
+		  (else
+		   (let ((node (car frontier)))
+		     (set-node-join-mark! node marker)
+		     (frontier-loop (cdr frontier)
+				    (if (eq? marker (node-seen-mark node))
+					to-do
+					(begin
+					  (set-node-seen-mark! node marker)
+					  (cons node to-do)))
+				    (cons node joins))))))))))
+
+; Integers as UID's
+
+(define *next-uid* 0)
+
+(define (next-uid)
+  (let ((uid *next-uid*))
+    (set! *next-uid* (+ uid 1))
+    uid))
+
+;----------------------------------------------------------------
+; Testing
+
+;(define-record-type data
+;  (name)
+;  (kids
+;   temp))
+;
+;(define-record-discloser type/data
+;  (lambda (data)
+;    (list 'data (data-name data))))
+;
+;(define (make-test-graph spec)
+;  (let ((vertices (map (lambda (d)
+;                         (data-maker (car d)))
+;                       spec)))
+;    (for-each (lambda (data vertex)
+;                (set-data-kids! vertex (map (lambda (s)
+;                                              (first (lambda (v)
+;                                                       (eq? s (data-name v)))
+;                                                     vertices))
+;                                            (cdr data))))
+;              spec
+;              vertices)
+;    vertices))
+
+;(define g1 (make-test-graph '((a b) (b c d) (c b e) (d d e) (e))))
+;(graph->ssa-graph (car g1) data-kids data-temp set-data-temp!)
+;(find-joins (list (list-ref g1 0)) data-temp)
\ No newline at end of file
diff --git a/ps-compiler/util/strong.scm b/ps-compiler/util/strong.scm
new file mode 100644
index 0000000..9dd94e0
--- /dev/null
+++ b/ps-compiler/util/strong.scm
@@ -0,0 +1,147 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+; Code to find the strongly connected components of a graph.
+; (TO <vertex>) are the vertices that have an edge to <vertex>.
+; (SLOT <vertex>) and (SET-SLOT! <vertex> <value>) is a settable slot
+; used by the algorithm.
+;
+; The components are returned in a backwards topologically sorted list.
+
+(define (strongly-connected-components vertices to slot set-slot!)
+  (make-vertices vertices to slot set-slot!)
+  (let loop ((to-do vertices) (index 0) (stack #t) (comps '()))
+    (let ((to-do (find-next-vertex to-do slot)))
+      (cond ((null? to-do)
+	     (for-each (lambda (n) (set-slot! n #f)) vertices)
+	     comps)
+	    (else
+	     (call-with-values
+	      (lambda () 
+		(do-vertex (slot (car to-do)) index stack comps))
+	      (lambda (index stack comps)
+		(loop to-do index stack comps))))))))
+
+(define (find-next-vertex vertices slot)
+  (do ((vertices vertices (cdr vertices)))
+      ((or (null? vertices)
+           (= 0 (vertex-index (slot (car vertices)))))
+       vertices)))
+
+(define-record-type vertex
+  (data            ; user's data
+   )
+  ((edges   '())   ; list of vertices
+   (stack    #f)   ; next vertex on the stack
+   (index    0)    ; time at which this vertex was reached in the traversal
+   (parent   #f)   ; a vertex pointing to this one
+   (lowpoint #f)   ; lowest index in this vertices strongly connected component
+   ))
+  
+(define (make-vertices vertices to slot set-slot!)
+  (let ((maybe-slot (lambda (n)
+		      (let ((s (slot n)))
+			(if (vertex? s)
+			    s
+			    (error "graph edge points to non-vertex" n))))))
+    (for-each (lambda (n)
+		(set-slot! n (vertex-maker n)))
+	      vertices)
+    (for-each (lambda (n)
+		(set-vertex-edges! (slot n) (map maybe-slot (to n))))
+	      vertices)
+    (values)))
+
+; The numbers are the algorithm step numbers from page 65 of Graph Algorithms,
+; Shimon Even, Computer Science Press, 1979.
+
+; 2
+
+(define (do-vertex vertex index stack comps)
+  (let ((index (+ index '1)))
+    (set-vertex-index!    vertex index)
+    (set-vertex-lowpoint! vertex index)
+    (set-vertex-stack!    vertex stack)
+    (get-strong vertex index vertex comps)))
+
+; 3
+
+(define (get-strong vertex index stack comps)
+  (if (null? (vertex-edges vertex))
+      (end-vertex    vertex index stack comps)
+      (follow-edge vertex index stack comps)))
+
+; 7
+
+(define (end-vertex vertex index stack comps)
+  (call-with-values
+   (lambda ()
+     (if (= (vertex-index vertex) (vertex-lowpoint vertex))
+	 (unwind-stack vertex stack comps)
+	 (values stack comps)))
+   (lambda (stack comps)
+     (cond ((vertex-parent vertex)
+	    => (lambda (parent)
+		 (if (> (vertex-lowpoint parent) (vertex-lowpoint vertex))
+		     (set-vertex-lowpoint! parent (vertex-lowpoint vertex)))
+		 (get-strong parent index stack comps)))
+	   (else
+	    (values index stack comps))))))
+
+(define (unwind-stack vertex stack comps)
+  (let loop ((n stack) (c '()))
+    (let ((next (vertex-stack n))
+          (c (cons (vertex-data n) c)))
+      (set-vertex-stack! n #f)
+      (if (eq? n vertex)
+          (values next (cons c comps))
+          (loop next c)))))
+
+; 4
+
+(define (follow-edge vertex index stack comps)
+  (let* ((next (pop-vertex-edge! vertex))
+         (next-index (vertex-index next)))
+    (cond ((= next-index 0)
+           (set-vertex-parent! next vertex)
+           (do-vertex next index stack comps))
+          (else
+           (if (and (< next-index (vertex-index vertex))
+                    (vertex-stack next)
+                    (< next-index (vertex-lowpoint vertex)))
+               (set-vertex-lowpoint! vertex next-index))
+           (get-strong vertex index stack comps)))))
+
+(define (pop-vertex-edge! vertex)
+  (let ((edges (vertex-edges vertex)))
+    (set-vertex-edges! vertex (cdr edges))
+    (car edges)))
+
+; GRAPH is ((<symbol> . <symbol>*)*)
+             
+;(define (test-strong graph)
+;  (let ((vertices (map (lambda (n)
+;                         (vector (car n) #f #f))
+;                       graph)))
+;    (for-each (lambda (data vertex)
+;                (vector-set! vertex 1 (map (lambda (s)
+;                                             (first (lambda (v)
+;                                                      (eq? s (vector-ref v 0)))
+;                                                    vertices))
+;                                           (cdr data))))
+;              graph
+;              vertices)
+;    (map (lambda (l)
+;           (map (lambda (n) (vector-ref n 0)) l))
+;         (strongly-connected-components vertices
+;                                        (lambda (v) (vector-ref v 1))
+;                                        (lambda (v) (vector-ref v 2))
+;                                        (lambda (v val)
+;                                          (vector-set! v 2 val))))))
+
+
+
+
+
+
+
diff --git a/ps-compiler/util/syntax.scm b/ps-compiler/util/syntax.scm
new file mode 100644
index 0000000..a4120a4
--- /dev/null
+++ b/ps-compiler/util/syntax.scm
@@ -0,0 +1,61 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+; Syntax used by the compiler
+
+; Subrecords
+;
+; SUPER is the name of the existing record
+; SUB is the name of the subrecord
+; SLOT is the name of the slot to use in the existing sturcture
+; STUFF is the usual stuff from DEFINE-RECORD-TYPE
+
+(define-syntax define-subrecord
+  (lambda (form rename compare)
+    (let ((super (cadr form))
+	  (sub (caddr form))
+	  (slot (cadddr form))
+	  (stuff (cddddr form)))
+      (let ((access-names (map (lambda (spec)
+				 (if (pair? spec) (car spec) spec))
+			       (append (car stuff) (cadr stuff))))
+	    (set-names (append (filter-map (lambda (spec)
+					     (if (pair? spec) (car spec) #f))
+					   (car stuff))
+			       (map (lambda (spec)
+				      (if (pair? spec) (car spec) spec))
+				    (cadr stuff)))))
+	`(begin (define-record-type ,sub . ,stuff)
+		,@(map (lambda (name)
+			 `(define ,(concatenate-symbol super '- name)
+			    (lambda (v)
+			      (,(concatenate-symbol sub '- name)
+			       (,slot v)))))
+		       access-names)
+		,@(map (lambda (name)
+			 `(define ,(concatenate-symbol 'set- super '- name '!)
+			    (lambda (v n)
+			      (,(concatenate-symbol 'set- sub '- name '!)
+			       (,slot v)
+			       n))))
+		       set-names))))))
+
+;(define-syntax define-simple-record-type
+;  (lambda (form rename compare)
+;    (let ((name (cadr form))
+;          (slots (cddr form)))
+;      `(begin (define-record-type ,name ,slots ())
+;              (define ,(concatenate-symbol 'make- name)
+;                ,(concatenate-symbol name '- 'maker))))))
+
+; Nothing actually local about it...
+
+(define-syntax define-local-syntax
+  (lambda (form rename compare)
+    (let ((pattern (cadr form))
+	  (body (cddr form)))
+      `(,(rename 'define-syntax) ,(car pattern)
+	 (,(rename 'lambda) (form rename compare)
+	   (,(rename 'destructure) ((,(cdr pattern)
+				     (,(rename 'cdr) form)))
+	     . ,body))))))
diff --git a/ps-compiler/util/transitive.scm b/ps-compiler/util/transitive.scm
new file mode 100644
index 0000000..3e0141b
--- /dev/null
+++ b/ps-compiler/util/transitive.scm
@@ -0,0 +1,401 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+; General transitive closure
+
+; (make-graph-from-predecessors nodes node-parents node-temp set-node-temp!)
+;            -> graph
+; (make-graph-from-successors nodes node-kids node-temp set-node-temp!)
+;            -> graph
+;
+; (transitive-or! graph elements set-elements! element-temp set-element-temp!)
+; (transitive-or-with-kill! graph elements set-elements! node-kills element-temp set-element-temp!)
+; (transitive-or-with-pass! graph elements set-elements! node-passes element-temp set-element-temp!)
+;
+; (transitive-and! graph elements set-elements! element-temp set-element-temp!)
+; (transitive-and-with-kill! graph elements set-elements! node-kills element-temp set-element-temp!)
+; (transitive-and-with-pass! graph elements set-elements! node-passes element-temp set-element-temp!)
+
+;----------------
+
+(define (make-graph-from-predecessors user-nodes user-node-parents node-temp set-node-temp!)
+  (let ((nodes (make-nodes user-nodes set-node-temp!)))
+    (connect-nodes-using-parents! nodes user-node-parents node-temp)
+    (for-each (lambda (node)
+		(set-node-temp! (node-data node) #f))
+	      nodes)
+    (make-graph nodes)))
+
+(define (make-graph-from-successors user-nodes user-node-kids node-temp set-node-temp!)
+  (let ((nodes (make-nodes user-nodes set-node-temp!)))
+    (connect-nodes-using-children! nodes user-node-kids node-temp)
+    (for-each (lambda (node)
+		(set-node-temp! (node-data node) #f))
+	      nodes)
+    (make-graph nodes)))
+
+(define (make-nodes user-nodes set-node-temp!)    
+  (map (lambda (data)
+	 (let ((node (node-maker data '() '())))
+	   (set-node-temp! data node)
+	   node))
+       user-nodes))
+
+(define-record-type graph
+  (nodes         ; list of nodes
+   )
+  ())
+
+(define make-graph graph-maker)
+  
+(define-record-type node
+  (data          ; user's data
+   (parents)     ; predecessors
+   (kids))       ; successors
+  (elt-set       ; elements
+   kill-set      ; elements that are not passed
+   changed?      ; change flag for iteration
+   ))
+
+;------------------------------
+; Six false fronts for the real procedure.
+
+(define (transitive-or! graph elts set-elts! elt-hash set-elt-hash!)
+  (do-it graph elts set-elts! #f #f elt-hash set-elt-hash!
+	 (transitive-or-closure! or-update-node)))
+
+(define (transitive-or-with-kill! graph elts set-elts! kill-elts elt-hash set-elt-hash!)
+  (do-it graph elts set-elts! kill-elts #f elt-hash set-elt-hash!
+	 (transitive-or-closure! or-update-node-with-kill)))
+
+(define (transitive-or-with-pass! graph elts set-elts! pass-elts elt-hash set-elt-hash!)
+  (do-it graph elts set-elts! pass-elts #t elt-hash set-elt-hash!
+	 (transitive-or-closure! or-update-node-with-kill)))
+
+(define (transitive-and! graph elts set-elts! elt-hash set-elt-hash!)
+  (do-it graph elts set-elts! #f #f elt-hash set-elt-hash!
+	 (transitive-and-closure! and-update-node)))
+
+(define (transitive-and-with-kill! graph elts set-elts! kill-elts elt-hash set-elt-hash!)
+  (do-it graph elts set-elts! kill-elts #f elt-hash set-elt-hash!
+	 (transitive-and-closure! and-update-node-with-kill)))
+
+(define (transitive-and-with-pass! graph elts set-elts! pass-elts elt-hash set-elt-hash!)
+  (do-it graph elts set-elts! pass-elts #t elt-hash set-elt-hash!
+	 (transitive-and-closure! and-update-node-with-kill)))
+
+(define (do-it graph elts set-elts! kill-elts pass? elt-hash set-elt-hash! op)
+  (let* ((nodes (graph-nodes graph))
+	 (elt-unhash-vec (add-elements! nodes elts kill-elts pass?
+					elt-hash set-elt-hash!)))
+    (op nodes)
+    (record-results! nodes elt-unhash-vec set-elts!)
+    (do ((i 0 (+ i 1)))
+	((= i (vector-length elt-unhash-vec)))
+      (set-elt-hash! (vector-ref elt-unhash-vec i) #f))
+    (values)))
+
+;----------------
+; Setting the kids field of the nodes
+
+(define (connect-nodes-using-children! nodes children node-slot)
+  (for-each
+   (lambda (node)
+     (set-node-kids! node
+		      (map (lambda (kid)
+			     (let ((t (node-slot kid)))
+			       (if (not (node? t))
+				   (missing-node-error kid "child" node))
+			       (set-node-parents! t
+						   (cons node
+							 (node-parents t)))
+			       t))
+			   (children (node-data node)))))
+   nodes))
+
+(define (connect-nodes-using-parents! nodes parents node-slot)
+  (for-each
+   (lambda (node)
+     (set-node-parents! node
+			 (map (lambda (parent)
+				(let ((t (node-slot parent)))
+				  (if (not (node? t))
+				      (missing-node-error t "parent" node))
+				  (set-node-kids! t
+						   (cons node
+							 (node-kids t)))
+				  t))
+			      (parents (node-data node)))))
+   nodes))
+
+(define (missing-node-error node relationship relation)
+  (error (format #f "Transitive - ~S, ~A of ~S, not in list of nodes"
+		 node relationship (node-data relation))))
+
+;----------------
+
+(define (add-elements! nodes node-elements node-kills pass?
+		       element-temp set-element-temp!)
+  (let ((unhash-vec (element-hasher nodes node-elements element-temp set-element-temp!))
+	(element-hash (make-element-hash element-temp)))
+    (for-each (lambda (node)
+		(set-node-elt-set! node
+				   (make-element-set (node-elements (node-data node))
+						     element-hash)))
+	      nodes)
+    (if node-kills
+	(for-each (lambda (node)
+		    (let ((kill-set (make-element-set (node-kills (node-data node))
+						      element-hash)))
+		      (set-node-kill-set! node (if pass?
+						   (integer-set-not kill-set)
+						   kill-set))))
+		  nodes))
+    unhash-vec))
+
+(define (make-element-set elts elt-hash)
+  (let loop ((elts elts) (set (make-empty-integer-set)))
+    (if (null? elts)
+	set
+	(loop (cdr elts)
+	      (cond ((elt-hash (car elts))
+		     => (lambda (hash)
+			  (add-to-integer-set set hash)))
+		    (else set))))))
+
+;----------------
+; Counting the elements and assigning numbers to them
+
+(define-record-type element-hash
+  (number  ; the element-hash record is just a way of tagging this number
+   )       ; with a unique predicate
+  ())
+
+(define (element-hasher nodes elts elt-hash set-elt-hash!)
+  (let loop ((to-do '()) (ts nodes) (all-elts '()) (count 0))
+    (cond ((null? to-do)
+	   (if (null? ts)
+	       (real-element-hasher all-elts count)
+	       (loop (elts (node-data (car ts))) (cdr ts) all-elts count)))
+	  ((element-hash? (elt-hash (car to-do)))
+	   (loop (cdr to-do) ts all-elts count))
+	  (else
+	   (set-elt-hash! (car to-do) (element-hash-maker count))
+	   (loop (cdr to-do) ts (cons (car to-do) all-elts) (+ count 1))))))
+
+(define (real-element-hasher elts count)
+  (let ((unhash-vec (make-vector count)))
+    (do ((i (- count 1) (- i 1))
+	 (elts elts (cdr elts)))
+	((null? elts))
+      (vector-set! unhash-vec i (car elts)))
+    unhash-vec))
+
+(define (make-element-hash elt-hash)
+  (lambda (elt)
+    (let ((hash (elt-hash elt)))
+      (if (element-hash? hash)
+	  (element-hash-number hash)
+	  #f))))
+
+;----------------
+; Turn the element sets into lists of elements and clean up stray pointers
+; at the same time.
+
+(define (record-results! nodes elt-unhash-vec set-elts!)
+  (for-each (lambda (node)
+	      (set-elts! (node-data node)
+			 (map-over-integer-set
+			  (lambda (i) (vector-ref elt-unhash-vec i))
+			  (node-elt-set node)))
+	      (set-node-elt-set! node #f)
+	      (set-node-kill-set! node #f))
+	    nodes))
+
+;----------------
+; The OR algorithm - keeps passing elements around until the changes stop.
+
+(define (transitive-or-closure! op)
+  (lambda (nodes)
+    (for-each (lambda (node)
+		(set-node-changed?! node #t))
+	      nodes)
+    (let loop ((to-do nodes))
+      (if (not (null? to-do))
+	  (let* ((node (car to-do))
+		 (elt-set (node-elt-set node)))
+	    (set-node-changed?! node #f)
+	    (let kids-loop ((ts (node-kids node))
+			    (to-do (cdr to-do)))
+	      (cond ((null? ts)
+		     (loop to-do))
+		    ((and (op (car ts) elt-set)
+			  (not (node-changed? (car ts))))
+		     (set-node-changed?! (car ts) #t)
+		     (kids-loop (cdr ts) (cons (car ts) to-do)))
+		    (else
+		     (kids-loop (cdr ts) to-do)))))))))
+
+; The weird function INTEGER-SET-SUBTRACT&IOR-WITH-TEST! takes three integer
+; sets, subtracts the second from the first and inclusive OR's the result
+; with the third.  It returns the resulting set and a flag which is #T if
+; the result is not the same as the original third set.  The inclusive OR
+; may be destructive.
+
+(define (or-update-node-with-kill node elt-set)
+  (receive (set change?)
+      (integer-set-subtract&ior-with-test! elt-set
+					   (node-kill-set node)
+					   (node-elt-set node))
+    (set-node-elt-set! node set)
+    change?))
+
+(define (or-update-node node elt-set)
+  (receive (set change?)
+      (integer-set-ior-with-test! elt-set
+				  (node-elt-set node))
+    (set-node-elt-set! node set)
+    change?))
+
+; Implementations using simpler, nondestructive operations (these might be
+; done more efficiently if they had access to the underlying representation
+; of integer sets).
+
+(define (integer-set-subtract&ior-with-test! set1 set2 set3)
+  (let ((result (integer-set-ior set3 (integer-set-subtract set1 set2))))
+    (values result (not (integer-set-equal? set3 result)))))
+
+(define (integer-set-ior-with-test! set1 set3)
+  (let ((result (integer-set-ior set3 set1)))
+    (values result (not (integer-set-equal? set3 result)))))
+
+;----------------
+; The AND algorithm - keeps a to-do list of nodes whose parents' elements
+; have changed, instead of a list of nodes whose elements have changed.
+
+(define (transitive-and-closure! op)
+  (lambda (nodes)
+    (let loop ((to-do (filter (lambda (node)
+				(if (not (null? (node-parents node)))
+				    (begin
+				      (set-node-changed?! node #t)
+				      #t)
+				    #f))
+			      nodes)))
+      (if (not (null? to-do))
+	  (let ((node (car to-do)))
+	    (set-node-changed?! node #f)
+	    (if (op node)
+		(let kids-loop ((ts (node-kids node))
+				(to-do (cdr to-do)))
+		  (cond ((null? ts)
+			 (loop to-do))
+			((node-changed? (car ts))
+			 (kids-loop (cdr ts) to-do))
+			(else
+			 (set-node-changed?! (car ts) #t)
+			 (kids-loop (cdr ts) (cons (car ts) to-do)))))
+		(loop (cdr to-do))))))))
+  
+; These are the same as for OR except that we AND together the parents'
+; elt-sets instead of using the one provided.
+
+(define (and-update-node-with-kill node)
+  (receive (set change?)
+      (integer-set-subtract&ior-with-test! (parents-elt-set node)
+					   (node-kill-set node)
+					   (node-elt-set node))
+    (set-node-elt-set! node set)
+    change?))
+  
+(define (and-update-node node)
+  (receive (set change?)
+      (integer-set-ior-with-test! (parents-elt-set node)
+				  (node-elt-set node))
+    (set-node-elt-set! node set)
+    change?))
+
+(define (parents-elt-set node)
+  (do ((parents (cdr (node-parents node))
+		(cdr parents))
+       (elts (node-elt-set (car (node-parents node)))
+	     (integer-set-and elts (node-elt-set (car parents)))))
+      ((null? parents)
+       elts)))
+
+;------------------------------------------------------------
+; Testing
+
+; GRAPH is ((<symbol>           name
+;            (element*)         elements
+;            (element*)         kills
+;            . <symbol*>)*)     children
+;
+'((node1 (elt1 elt2) ()     node2)
+  (node2 (elt3)      (elt2) node1 node3)
+  (node3 ()          ()     ))
+
+'((a (1) () b)
+  (b ()  () ))
+
+'((a (1 2 3 4) (1) b)
+  (b ()        (2) c)
+  (c ()        (3) d)
+  (d (5)       (4) a))
+             
+(define (test-transitive graph down? or? pass?)
+  (let* ((elts '())
+	 (get-elt (lambda (sym)
+		    (cond ((first (lambda (v)
+				    (eq? sym (vector-ref v 0)))
+				  elts)
+			   => identity)
+			  (else
+			   (let ((new (vector sym #f)))
+			     (set! elts (cons new elts))
+			     new)))))
+	 (vertices (map (lambda (n)
+			  (vector (car n)
+				  (map get-elt (cadr n))
+				  (map get-elt (caddr n))
+				  #f #f))
+			graph)))
+    (for-each (lambda (data vertex)
+		(vector-set! vertex 3 (map (lambda (s)
+					     (first (lambda (v)
+						      (eq? s (vector-ref v 0)))
+						    vertices))
+					   (cdddr data))))
+	      graph
+	      vertices)
+    (let ((the-graph ((if down?
+			  make-graph-from-successors
+			  make-graph-from-predecessors)
+		      vertices
+		      (lambda (x) (vector-ref x 3))
+		      (lambda (x) (vector-ref x 4))
+		      (lambda (x v) (vector-set! x 4 v)))))
+      (if (every? (lambda (n) (null? (caddr n))) graph)
+	  ((if or? transitive-or! transitive-and!)
+	   the-graph
+	   (lambda (v) (vector-ref v 1))        ; elts
+	   (lambda (v x) (vector-set! v 1 x))   ; set-elts!
+	   (lambda (e) (vector-ref e 1))        ; elt-hash
+	   (lambda (e x) (vector-set! e 1 x)))  ; set-elt-hash!
+          ((if or?					    
+	       (if pass?
+		   transitive-or-with-pass!
+		   transitive-or-with-kill!)
+	       (if pass?
+		   transitive-and-with-pass!
+		   transitive-and-with-kill!))
+	   the-graph
+	   (lambda (v) (vector-ref v 1))         ; elts
+	   (lambda (v x) (vector-set! v 1 x))    ; set-elts!
+	   (lambda (v) (vector-ref v 2))         ; kills
+	   (lambda (e) (vector-ref e 1))         ; elt-hash
+	   (lambda (e x) (vector-set! e 1 x))))) ; set-elt-hash!
+    (map (lambda (v)
+	   (list (vector-ref v 0)
+		 (map (lambda (e) (vector-ref e 0))
+		      (vector-ref v 1))))
+	 vertices)))
diff --git a/ps-compiler/util/util.scm b/ps-compiler/util/util.scm
new file mode 100644
index 0000000..6873505
--- /dev/null
+++ b/ps-compiler/util/util.scm
@@ -0,0 +1,187 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+; Messages
+;==========================================================================
+
+(define (bug format-string . args)
+  (apply error (list "~?~%  (compiler error)" format-string args)))
+
+(define (user-error format-string . args)
+  (apply error (list "~?~%  (source error)" format-string args)))
+
+(define (user-warning format-string . args)
+  (apply error (list "~?~%  (source error)" format-string args)))
+
+; Little utilities.
+;========================================================================
+
+(define (true  x) #t)
+(define (false x) #f)
+
+(define (or-map proc list)
+  (do ((list list (cdr list))
+       (r '#f (or (proc (car list)) r)))
+      ((null? list) r)))
+
+(define (remove-similar-elts pred list)
+  (do ((list list (cdr list))
+       (res  '()  (if (mem? pred (car list) res)
+                      res
+                      (cons (car list) res))))
+      ((null-list? list)
+       res)))
+
+(define (select-from-table pred table)
+  (let ((res '()))
+    (table-walk (lambda (key entry)
+                  (if (pred key entry)
+                      (set! res `((,key . ,entry) . ,res))))
+                table)
+    res))
+
+(define (table->list table)
+  (select-from-table (lambda (x y) #t) table))
+
+(define (table->entry-list table)
+  (let ((res '()))
+    (table-walk (lambda  (key entry)
+                  (set! res (cons entry res)))
+                table)
+    res))
+
+(define (table-push table key val)
+  (let ((old (table-ref table key)))
+    (table-set! table key (if old
+			      (cons val old)
+			      (list val)))
+    val))
+
+(define (table-pop table key)
+  (let ((old (table-ref table key)))
+    (table-set! table key (cdr old))
+    (car old)))
+
+(define (merge-lists x y)
+  (cond ((null? y) x)
+        (else (do ((z x (cdr z))
+                   (u y (let ((w (car z)))
+                          (if (memq? w u) u (cons w u)))))
+                  ((null? z) u)))))
+
+(define (vector-every? pred vec)
+  (let loop ((i (- (vector-length vec) '1)))
+    (cond ((< i '0)
+	   '#t)
+          ((not (pred (vector-ref vec i)))
+	   '#f)
+          (else
+	   (loop (- i '1))))))
+
+(define (make-ignorable vars)
+  (let loop ((vars vars) (res '()))
+    (cond ((null? vars)
+           `(ignorable . ,res))
+          ((atom? vars)
+           `(ignorable ,vars . ,res))
+          (else
+           (loop (cdr vars) (cons (car vars) res))))))
+
+(define (sub-vector->list vec start)
+  (do ((i (- (vector-length vec) '1) (- i '1))
+       (r '() (cons (vector-ref vec i) r)))
+      ((< i start)
+       r)))
+
+; A version of ASSQ that works on lists containing atoms.
+
+(define (flag-assq obj list)
+  (let loop ((l list))
+    (if (null-list? l) 
+        #f
+        (let ((z (car l)))
+          (if (and (pair? z)
+                   (eq? obj (car z)))
+              z
+              (loop (cdr l)))))))
+
+; T system stuff
+
+(define (enforce predicate value)
+  (if (predicate value)
+      value
+      (error "enforce ~A failed on ~A" predicate value)))
+
+(define (writec port char)
+  (write-char char port))
+
+(define (mem? predicate object list)
+  (let loop ((list list))
+    (cond ((null? list)
+	   #f)
+	  ((predicate object (car list))
+	   #t)
+	  (else
+	   (loop (cdr list))))))
+
+(define (walk-vector procedure vector)
+  (do ((i 0 (+ i 1)))
+      ((>= i (vector-length vector))
+       (values))
+    (procedure (vector-ref vector i))))
+
+(define (vector-replace to from count)
+  (do ((i 0 (+ i 1)))
+      ((>= i count))
+    (vector-set! to i (vector-ref from i)))
+  (values))
+
+(define (copy-vector vector)
+  (let ((new (make-vector (vector-length vector))))
+    (do ((i 0 (+ i 1)))
+	((= i (vector-length vector)))
+      (vector-set! new i (vector-ref vector i)))
+    new))
+
+(define (copy-list list)
+  (if (null-list? list)
+      list
+      (let ((copy (cons (car list) '())))
+	(let loop ((list (cdr list)) (result copy))
+	  (cond ((not (null-list? list))
+		 (let ((next (cons (car list) '())))
+		   (set-cdr! result next)
+		   (loop (cdr list) next)))))
+	copy)))
+
+(define (symbol-hash symbol)
+  (string-hash (symbol->string symbol)))
+
+(define string-hash (structure-ref features string-hash))
+
+(define (object-hash x)
+  0)           ; wah!
+
+(define (union l1 l2)
+  (if (null? l2)
+      l1
+      (do ((l1 l1 (cdr l1))
+	   (res l2 (if (memq? (car l1) res) res (cons (car l1) res))))
+	  ((null? l1)
+	   res))))
+
+(define (intersection l1 l2)
+  (if (null? l2)
+      '()
+      (do ((l1 l1 (cdr l1))
+	   (res '() (if (memq? (car l1) l2) (cons (car l1) res) res)))
+	  ((null? l1)
+	   res))))
+
+(define (set-difference l1 l2)
+  (if (null? l2)
+      l1
+      (do ((l1 l1 (cdr l1))
+	   (res '() (if (memq? (car l1) l2) res (cons (car l1) res))))
+	  ((null? l1)
+	   res))))
diff --git a/ps-compiler/util/z-set.scm b/ps-compiler/util/z-set.scm
new file mode 100644
index 0000000..2df83d2
--- /dev/null
+++ b/ps-compiler/util/z-set.scm
@@ -0,0 +1,38 @@
+; Copyright (c) 1993-1999 by Richard Kelsey.  See file COPYING.
+
+
+; Sets of integers implemented as integers.
+
+(define (make-empty-integer-set)
+  0)
+
+(define (add-to-integer-set set integer)
+  (bitwise-ior set (arithmetic-shift 1 integer)))
+
+(define integer-set-chunk-size 24)
+(define word-mask (- (arithmetic-shift 1 integer-set-chunk-size) 1))
+
+; The nested loop reduces the amount of bignum arithmetic needed (and reduces
+; the time by as much as a factor of 10).
+
+(define (map-over-integer-set proc set)
+  (do ((set set (arithmetic-shift set (- integer-set-chunk-size)))
+       (i 0 (+ i integer-set-chunk-size))
+       (l '() (do ((set (bitwise-and set word-mask) (arithmetic-shift set -1))
+		   (j 0 (+ j 1))
+		   (l l (if (odd? set)
+			    (cons (proc (+ i j)) l)
+			    l)))
+		  ((or (= 0 set) (>= j integer-set-chunk-size))
+		   l))))
+      ((= 0 set)
+       (reverse l))))
+
+(define integer-set-and bitwise-and)
+(define integer-set-ior bitwise-ior)
+(define integer-set-not bitwise-not)
+
+(define (integer-set-subtract set1 set2)
+  (bitwise-and set1 (bitwise-not set2)))
+
+(define integer-set-equal? =)
\ No newline at end of file
diff --git a/scheme/alt-packages.scm b/scheme/alt-packages.scm
new file mode 100644
index 0000000..4b364d1
--- /dev/null
+++ b/scheme/alt-packages.scm
@@ -0,0 +1,135 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This configuration file provides alternative implementations of the
+; low, run-time, and run-time-internals structures.  Cf. the interface
+; definitions in packages.scm.
+
+(define-structure scheme-level-0 scheme-level-0-interface
+  (open scheme))
+
+(define-structure escapes escapes-interface ;cf. alt/low-packages.scm
+  (open scheme-level-2 define-record-types signals)
+  (files (alt escape)))
+
+(define-structures ((low-level low-level-interface)
+		    (source-file-names (export (%file-name% :syntax)))
+		    (structure-refs (export (structure-ref :syntax))))
+  (open scheme-level-2 signals)
+  (files (alt low)))
+
+(define-structure closures closures-interface
+  (open scheme-level-1 records)
+  (files (alt closure)))
+
+(define-structure locations locations-interface
+  (open scheme-level-2 records)
+  (files (alt locations)))
+
+(define-structure loopholes (export (loophole :syntax))
+  (open scheme-level-2)
+  (files (alt loophole)))
+
+(define-structure silly (export reverse-list->string)
+  (open scheme-level-1)
+  (files (alt silly)))
+
+(define-structure write-images (export write-image)
+  (open scheme-level-2
+	tables			;Forward reference
+	features bitwise ascii enumerated
+	architecture
+	templates
+	closures
+	signals)
+  (files (link data)
+	 (link transport)
+	 (link write-image)))
+
+; --------------------
+; run-time (generally speaking, things needed by the linker)
+
+; Same as in rts-packages.scm:
+(define-structure architecture architecture-interface
+  (open scheme-level-1 signals enumerated)
+  (files (vm arch)))
+
+(define-structure define-record-types define-record-types-interface
+  (open scheme-level-1 records)
+  (files (alt jar-defrecord)))
+
+; Same as in rts-packages.scm:
+(define-structure enumerated enumerated-interface
+  (open scheme-level-1 signals)
+  (files (rts defenum scm)))
+
+(define-structure fluids fluids-interface
+  (open scheme-level-1 signals)
+  (files (alt fluid)))
+
+(define-structures ((scheme-level-2 scheme-level-2-interface)
+		    (scheme-level-1 scheme-level-1-interface))
+  (open scheme))
+
+(define-structure templates templates-interface
+  (open scheme-level-1)
+  (files (alt template)
+	 (rts template)))
+
+(define-structure util util-interface
+  (open scheme-level-1)
+  (files (rts util)))
+
+(define-structure weak weak-interface
+  (open scheme-level-1 signals)
+  (files (alt weak)
+	 (rts population)))
+
+
+; --------------------
+; run-time internals (generally speaking, things not needed by the linker)
+
+; * = mentioned in more-packages.scm
+;   conditions
+;   continuations
+;   display-conditions
+; * exceptions
+; * fluids-internal
+;   methods
+;   meta-methods
+;   interrupts
+;   low-level
+;   more-types
+; * number-i/o
+; * ports
+; * reading
+; * records-internal
+;   usual-resumer
+; * wind
+;   writing
+
+(define-structure wind wind-interface
+  (open scheme-level-2)
+  (files (alt reroot)))
+
+(define-structure continuations continuations-interface
+  (open scheme-level-1 templates methods)
+  (files (alt contin)
+	 (rts continuation))
+  (optimize auto-integrate))
+
+; --------------------
+; These don't really belong here, but I sure don't know where they
+; ought to go.
+
+(define-structure environments (export *structure-ref)
+  (open )				;Assume flatloading
+  (files (alt environments)))
+
+
+; Procedure annotations
+
+(define-structure annotations
+    (export annotate-procedure procedure-annotation)
+  (open scheme-level-1)
+  (files (alt annotate)))
diff --git a/scheme/alt/ascii.scm b/scheme/alt/ascii.scm
new file mode 100644
index 0000000..cad56c1
--- /dev/null
+++ b/scheme/alt/ascii.scm
@@ -0,0 +1,69 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+;;;; Portable definitions of char->ascii and ascii->char
+
+; Don't detabify this file!
+
+; This module defines char->ascii and ascii->char in terms of
+; char->integer and integer->char, with no assumptions about the encoding.
+; Portable except maybe for the strings that contain tab, page, and
+; carriage return characters.  Those can be flushed if necessary.
+
+(define ascii-limit 128)
+
+(define ascii-chars
+  (let* ((ascii-chars (make-vector ascii-limit #f))
+	 (unusual (lambda (s)
+		    (if (or (not (= (string-length s) 1))
+			    (let ((c (string-ref s 0)))
+			      (or (char=? c #\space)
+				  (char=? c #\newline))))
+			(error "unusual whitespace character lost" s)
+			s)))
+	 (init (lambda (i s)
+		 (do ((i i (+ i 1))
+		      (j 0 (+ j 1)))
+		     ((= j (string-length s)))
+		   (vector-set! ascii-chars i (string-ref s j))))))
+    (init 9 (unusual "	"))   ;tab
+    (init 12 (unusual ""))  ;page
+    (init 13 (unusual "
"))  ;carriage return
+    (init 10 (string #\newline))
+    (init 32 " !\"#$%&'()*+,-./0123456789:;<=>?")
+    (init 64 "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_")
+    (init 96 "`abcdefghijklmnopqrstuvwxyz{|}~")
+    ascii-chars))
+
+(define (ascii->char n)
+  (or (vector-ref ascii-chars n)
+      (error "not a standard character's ASCII code" n)))
+
+(define native-chars
+  (let ((end (vector-length ascii-chars)))
+    (let loop ((i 0)
+	       (least    #f)
+	       (greatest #f))
+      (cond ((= i end)
+	     (let ((v (make-vector (+ (- greatest least) 1) #f)))
+	       (do ((i 0 (+ i 1)))
+		   ((= i end) (cons least v))
+		 (let ((c (vector-ref ascii-chars i)))
+		   (if c
+		       (vector-set! v (- (char->integer c) least) i))))))
+	    (else
+	     (let ((c (vector-ref ascii-chars i)))
+	       (if c
+		   (let ((n (char->integer c)))
+		     (loop (+ i 1)
+			   (if least    (min least    n) n)
+			   (if greatest (max greatest n) n)))
+		   (loop (+ i 1) least greatest))))))))
+
+(define (char->ascii char)
+  (or (vector-ref (cdr native-chars)
+		  (- (char->integer char) (car native-chars)))
+      (error "not a standard character" char)))
+
+(define ascii-whitespaces '(32 10 9 12 13)) ;space linefeed tab page return
diff --git a/scheme/alt/bitwise-tests.scm b/scheme/alt/bitwise-tests.scm
new file mode 100644
index 0000000..665adfb
--- /dev/null
+++ b/scheme/alt/bitwise-tests.scm
@@ -0,0 +1,58 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Lost: (ARITHMETIC-SHIFT 5 27) => -402653184 [wanted 671088640.]
+; Lost: (ARITHMETIC-SHIFT 5 28) => 268435456 [wanted 1342177280.]
+
+
+(define (testit name proc x y z)
+  (let ((result (proc x y)))
+    (if (not (= result z))
+	(begin (display "Lost: ")
+	       (write `(,name ,x ,y))
+	       (display " => ")
+	       (write result)
+	       (display " [wanted ")
+	       (write z)
+	       (display "]")
+	       (newline)))))
+
+(define most-positive-fixnum
+  (let ((n (arithmetic-shift 2 27))) (+ n (- n 1))))
+
+(define (test-left-shifts x)
+  (let ((crossover (arithmetic-shift 2 27)))
+    (do ((y 0 (+ y 1))
+	 (z x (* z (if (>= z crossover) 2. 2))))
+	((= y 34))
+      (testit 'arithmetic-shift arithmetic-shift x y z))))
+
+(test-left-shifts 5)
+(test-left-shifts -5)
+
+(define (test-right-shifts x)
+  (do ((y 0 (- y 1))
+       (z x (quotient z 2)))
+      ((= y -34))
+    (testit 'arithmetic-shift arithmetic-shift x y z)))
+
+(test-right-shifts (* 5 (expt 2 36)))
+(test-right-shifts (* -5 (expt 2 36)))
+
+(define (bit1? x)
+  (if (< x 0)
+      (even? (quotient (- -1 x) 2))
+      (odd? (quotient x 2))))
+
+(define (try-truth-table name proc predicate)
+  (do ((x -4 (+ x 1)))
+      ((= x 4))
+    (do ((y -4 (+ y 1)))
+	((= y 4))
+      (testit name proc x y
+	      (+ (if (predicate (odd? x) (odd? y)) 1 0)
+		 (if (predicate (bit1? x) (bit1? y)) 2 0)
+		 (if (predicate (negative? x) (negative? y)) -4 0))))))
+
+(try-truth-table 'bitwise-and bitwise-and (lambda (a b) (and a b)))
+(try-truth-table 'bitwise-ior bitwise-ior (lambda (a b) (or a b)))
diff --git a/scheme/alt/bitwise.scm b/scheme/alt/bitwise.scm
new file mode 100644
index 0000000..1a1f4f6
--- /dev/null
+++ b/scheme/alt/bitwise.scm
@@ -0,0 +1,44 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Bitwise operators written in vanilla Scheme.
+; Written for clarity and simplicity, not for speed.
+
+; No need to use these in Scheme 48 since Scheme 48's virtual machine
+; provides fast machine-level implementations.
+
+
+(define (bitwise-not i)
+  (- -1 i))
+
+(define (bitwise-and x y)
+  (cond ((= x 0) 0)
+	((= x -1) y)
+	(else
+	 (+ (* (bitwise-and (arithmetic-shift x -1)
+			    (arithmetic-shift y -1))
+	       2)
+	    (* (modulo x 2) (modulo y 2))))))
+
+(define (bitwise-ior x y)
+  (bitwise-not (bitwise-and (bitwise-not x)
+			    (bitwise-not y))))
+
+(define (bitwise-xor x y)
+  (bitwise-and (bitwise-not (bitwise-and x y))
+	       (bitwise-ior x y)))
+
+(define (bitwise-eqv x y)
+  (bitwise-not (bitwise-xor x y)))
+
+
+(define (arithmetic-shift n m)
+  (floor (* n (expt 2 m))))
+
+
+(define (count-bits x)		; Count 1's in the positive 2's comp rep
+  (let ((x (if (< x 0) (bitwise-not x) x)))
+    (do ((x x (arithmetic-shift x 1))
+	 (result 0 (+ result (modulo x 2))))
+	((= x 0) result))))
+
+;(define (integer-length integer) ...) ;?
diff --git a/scheme/alt/closure.scm b/scheme/alt/closure.scm
new file mode 100644
index 0000000..3cabfaf
--- /dev/null
+++ b/scheme/alt/closure.scm
@@ -0,0 +1,11 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+
+; Closures
+
+(define closure-rtd      (make-record-type 'closure '(template env)))
+(define closure?         (record-predicate closure-rtd))
+(define make-closure     (record-constructor closure-rtd '(template env)))
+(define closure-template (record-accessor closure-rtd 'template))
+(define closure-env	 (record-accessor closure-rtd 'env))
diff --git a/scheme/alt/code-vector.scm b/scheme/alt/code-vector.scm
new file mode 100644
index 0000000..6121bc9
--- /dev/null
+++ b/scheme/alt/code-vector.scm
@@ -0,0 +1,19 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Code-vectors implemented as vectors.
+
+(define *code-vector-marker* (list '*code-vector-marker*))
+
+(define (make-code-vector len init)
+  (let ((t (make-vector (+ len 1) init)))
+    (vector-set! t 0 *code-vector-marker*)
+    t))
+
+(define (code-vector? obj)
+  (and (vector? obj)
+       (> (vector-length obj) 0)
+       (eq? (vector-ref obj 0) *code-vector-marker*)))
+
+(define (code-vector-length t) (- (vector-length t) 1))
+(define (code-vector-ref t i) (vector-ref t (+ i 1)))
+(define (code-vector-set! t i x) (vector-set! t (+ i 1) x))
diff --git a/scheme/alt/config.scm b/scheme/alt/config.scm
new file mode 100644
index 0000000..87e4248
--- /dev/null
+++ b/scheme/alt/config.scm
@@ -0,0 +1,199 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Stub support for DEFINE-PACKAGE and DEFINE-INTERFACE macros.
+
+; Interfaces are ignored.  Only dependencies are significant.
+
+
+(define (load-configuration filename . rest)
+  (let ((save filename))
+    (dynamic-wind (lambda () (set! *source-file-name* filename))
+		  (lambda ()
+		    (apply load filename rest))
+		  (lambda () (set! *source-file-name* save)))))
+(define (%file-name%) *source-file-name*)
+(define *source-file-name* "")
+
+
+; This is used to generate file lists that are "included" in "makefiles."
+
+(define (write-file-names target . stuff)
+  (call-with-output-file target
+    (lambda (port)
+      (display "Writing ") (display target) (newline)
+      (display "#### This file was generated automatically. ####"
+	       port)
+      (newline port)
+      (let ((mumble (lambda (name filenames)
+		      (newline port)
+		      (display name port)
+		      (display " = " port)
+		      (for-each (lambda (filename)
+				  (display filename port)
+				  (display " " port))
+				filenames)
+		      (newline port))))
+	(do ((stuff stuff (cddr stuff)))
+	    ((null? stuff))
+	  (mumble (car stuff) (cadr stuff)))
+	;(mumble 'all-files (reverse *all-files*))
+	))))
+
+
+; --------------------
+
+(define (make-indirect-interface name thunk)
+  (thunk))
+
+
+(define (make-simple-interface name items)
+  (cons 'export items))
+
+(define (make-compound-interface name . sigs)
+  (cons 'compound-interface sigs))
+
+
+; Structures are views into packages.
+; In this implementation, interface information is completely ignored.
+
+(define-syntax make-structure
+  (syntax-rules ()
+    ((make-structure ?package ?interface ?name)
+     (vector '<structure> ?name ?package))
+    ((make-structure ?package ?interface)
+     (make-structure ?package ?interface #f))))
+
+(define (structure-name s) (vector-ref s 1))
+(define (structure-package s) (vector-ref s 2))
+
+(define (verify-later! thunk) 'lose)
+;(define *all-files* '())
+
+
+; Packages are not what they appear to be.
+
+(define (make-a-package opens-thunk accesses-thunk tower
+			file-name clauses name)
+  (vector '<a-package>
+	  (delay (opens-thunk))
+	  (delay (accesses-thunk))
+	  file-name
+	  clauses
+	  #f))
+
+(define (package-opens p)     (force (vector-ref p 1)))
+(define (package-accesses p)  (force (vector-ref p 2)))
+(define (package-file-name p) (vector-ref p 3))
+(define (package-clauses p)   (vector-ref p 4))
+(define (package-loaded? p) (vector-ref p 5))
+(define (set-package-loaded?! p ?) (vector-set! p 5 ?))
+
+(define dummy-package
+  (make-a-package (lambda () '()) (lambda () '()) #f "" '() #f))
+
+; source-file-names  ?
+(define module-system (make-structure dummy-package #f 'module-system))
+(define scheme (make-structure dummy-package #f 'scheme))
+(define built-in-structures
+  (make-structure dummy-package #f 'built-in-structures))
+
+(define (note-name! thing name)
+  thing)
+
+
+; Handy
+
+(define (setdiff l1 l2)
+  (cond ((null? l2) l1)
+	((null? l1) l1)
+	((member (car l1) l2)
+	 (setdiff (cdr l1) l2))
+	(else (cons (car l1)
+		    (setdiff (cdr l1) l2)))))
+
+
+; Stuff copied from rts/filename.scm... ugh...
+
+; Namelist = ((dir ...) basename type)
+;         or ((dir ...) basename)
+;	  or (dir basename type)
+;	  or (dir basename)
+;	  or basename
+
+(define (namestring namelist dir default-type)
+  (let ((namelist (if (list? namelist) namelist (list '() namelist))))
+    (let ((subdirs (if (list? (car namelist))
+		       (car namelist)
+		       (list (car namelist))))
+	  (basename (cadr namelist))
+	  (type (if (null? (cddr namelist))
+		    default-type
+		    (caddr namelist))))
+      (string-append (or dir "")
+		     (apply string-append
+			    (map (lambda (subdir)
+				   (string-append
+				      (namestring-component subdir)
+				      directory-component-separator))
+				 subdirs))
+		     (namestring-component basename)
+		     (if type
+			 (string-append type-component-separator
+					(namestring-component type))
+			 "")))))
+
+(define directory-component-separator "/") ;unix sux
+(define type-component-separator ".")
+
+(define (namestring-component x)
+  (cond ((string? x) x)
+	((symbol? x)
+	 (list->string (map file-name-preferred-case
+			    (string->list (symbol->string x)))))
+	(else
+	 ;; (error "bogus namelist component" x)
+	 "bogus namelist component")))
+
+(define file-name-preferred-case char-downcase)
+
+(define *scheme-file-type* 'scm)
+(define *load-file-type* *scheme-file-type*)  ;#F for Pseudoscheme or T
+
+(define (file-name-directory filename)
+  (substring filename 0 (file-nondirectory-position filename)))
+
+(define (file-name-nondirectory filename)
+  (substring filename
+	     (file-nondirectory-position filename)
+	     (string-length filename)))
+
+(define (file-nondirectory-position filename)
+  (let loop ((i (- (string-length filename) 1)))
+    (cond ((< i 0) 0)
+	  ;; Heuristic.  Should work for DOS, Unix, VMS, MacOS.
+          ((string-posq (string-ref filename i) "/:>]\\") (+ i 1))
+          (else (loop (- i 1))))))
+
+(define (string-posq thing s)
+  (let loop ((i 0))
+    (cond ((>= i (string-length s)) #f)
+          ((eq? thing (string-ref s i)) i)
+          (else (loop (+ i 1))))))
+
+; Types
+(define :value ':value)
+(define :syntax ':syntax)
+(define :structure ':structure)
+(define :procedure ':procedure)
+(define :number ':number)
+(define :type ':type)
+
+(define-syntax proc
+  (lambda (e r c) ''proc-lossage))
+
+(define-syntax interface-of
+  (lambda (e r c) ''interface-of-lossage))
+
+
+(define-reflective-tower-maker list)
diff --git a/scheme/alt/contin.scm b/scheme/alt/contin.scm
new file mode 100644
index 0000000..badfb4e
--- /dev/null
+++ b/scheme/alt/contin.scm
@@ -0,0 +1,20 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Continuations implemented as vectors.
+
+(define *continuation-marker* (list '*continuation-marker*))
+
+(define (make-continuation len init)
+  (let ((c (make-vector (+ len 1) init)))
+    (vector-set! c 0 *continuation-marker*)
+    c))
+
+(define (continuation? obj)
+  (and (vector? obj)
+       (> (vector-length obj) 0)
+       (eq? (vector-ref obj 0) *continuation-marker*)))
+
+(define (continuation-length c) (- (vector-length c) 1))
+(define (continuation-ref c i) (vector-ref c (+ i 1)))
+(define (continuation-set! c i x) (vector-set! c (+ i 1) x))
diff --git a/scheme/alt/environments.scm b/scheme/alt/environments.scm
new file mode 100644
index 0000000..dd990bb
--- /dev/null
+++ b/scheme/alt/environments.scm
@@ -0,0 +1,7 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; don't put a copyright notice, silly shell script
+
+(define (*structure-ref struct name)
+  (eval name (interaction-environment)))
+
diff --git a/scheme/alt/escape.scm b/scheme/alt/escape.scm
new file mode 100644
index 0000000..da90946
--- /dev/null
+++ b/scheme/alt/escape.scm
@@ -0,0 +1,32 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+
+; For an explanation, see comments in rts/low.scm.
+
+; The debugger invokes EXTRACT-CONTINUATION on a "native" continuation
+; as obtained by PRIMITIVE-CWCC in order to get a VM continuation.
+; The distinction between native and VM continuations is useful when
+; debugging a program running under a VM that's different from
+; whatever machine is running the debugger.
+
+(define-record-type escape :escape
+  (make-escape proc)
+  (proc escape-procedure))
+
+(define (with-continuation esc thunk)
+  (if esc
+      ((escape-procedure esc) thunk)
+      (let ((answer (thunk)))
+	(signal 'vm-return answer)	;#f means halt
+	(call-error "halt" answer))))
+
+(define (primitive-cwcc proc)
+  (call-with-current-continuation
+    (lambda (done)
+      ((call-with-current-continuation
+	 (lambda (k)
+	   (call-with-values
+	       (lambda ()
+		 (proc (make-escape k)))
+	     done)))))))
diff --git a/scheme/alt/features-packages.scm b/scheme/alt/features-packages.scm
new file mode 100644
index 0000000..91cc0ea
--- /dev/null
+++ b/scheme/alt/features-packages.scm
@@ -0,0 +1,29 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+
+; The following several packages have Scheme-implementation-specific 
+; variants that are much better for one reason or another than
+; the generic versions defined here.
+
+(define-structures ((signals signals-interface)
+		    (handle (export ignore-errors))
+		    (features features-interface))
+  (open scheme-level-2)
+  (files features))
+
+(define-structure records records-interface
+  (open scheme-level-2 signals)
+  (files record))
+
+(define-structure ascii (export ascii->char char->ascii)
+  (open scheme-level-2 signals)
+  (files ascii))
+
+(define-structure bitwise bitwise-interface
+  (open scheme-level-2 signals)
+  (files bitwise))
+
+(define-structure code-vectors code-vectors-interface
+  (open scheme-level-1)
+  (files code-vectors))
diff --git a/scheme/alt/features.scm b/scheme/alt/features.scm
new file mode 100644
index 0000000..707accb
--- /dev/null
+++ b/scheme/alt/features.scm
@@ -0,0 +1,53 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This is file features.scm.
+; Synchronize any changes with all the other *-features.scm files.
+
+; These definitions should be quite portable to any Scheme implementation.
+; Assumes Revised^5 Report Scheme, for EVAL and friends.
+
+
+; SIGNALS
+
+(define (error message . irritants)
+  (display-error-message "Error: " message irritants)
+  (an-error-occurred-now-what?))
+
+(define (warn message . irritants)
+  (display-error-message "Warning: " message irritants))
+
+(define (display-error-message heading message irritants)
+  (display heading)
+  (display message)
+  (newline)
+  (let ((spaces (list->string
+		 (map (lambda (c) #\space) (string->list heading)))))
+    (for-each (lambda (irritant)
+		(display spaces)
+		(write irritant)
+		(newline))
+	      irritants)))
+
+; Linker also needs SIGNAL, SYNTAX-ERROR, CALL-ERROR
+
+; FEATURES
+
+(define (force-output port) #f)
+
+(define current-noise-port current-output-port)
+
+(define (string-hash s)
+  (let ((n (string-length s)))
+    (do ((i 0 (+ i 1))
+         (h 0 (+ h (char->ascii (string-ref s i)))))
+        ((>= i n) h))))
+
+(define (make-immutable! thing) #f)
+(define (immutable? thing) #f)
+(define (unspecific) (if #f #f))
+
+
+; BITWISE -- use alt/bitwise.scm (!)
+; ACII -- use alt/ascii.scm
+; CODE-VECTORS -- use alt/code-vectors.scm
diff --git a/scheme/alt/fluid.scm b/scheme/alt/fluid.scm
new file mode 100644
index 0000000..d520b21
--- /dev/null
+++ b/scheme/alt/fluid.scm
@@ -0,0 +1,33 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Fluid variables
+
+(define (make-fluid val)
+  (vector '<fluid> val))
+
+(define (fluid f) (vector-ref f 1))
+
+(define (set-fluid! f val)
+  (vector-set! f 1 val))
+
+(define (let-fluid f val thunk)
+  (let ((swap (lambda () (let ((temp (fluid f)))
+			   (set-fluid! f val)
+			   (set! val temp)))))
+    (dynamic-wind swap thunk swap)))
+
+(define (let-fluids . args)		;Kind of gross
+  (let loop ((args args)
+	     (swap (lambda () #f)))
+    (if (null? (cdr args))
+	(dynamic-wind swap (car args) swap)
+	(loop (cddr args)
+	      (let ((f (car args))
+		    (val (cadr args)))
+		(lambda ()
+		  (swap)
+		  (let ((temp (fluid f)))
+		    (set-fluid! f val)
+		    (set! val temp))))))))
+		
diff --git a/scheme/alt/init-defpackage.scm b/scheme/alt/init-defpackage.scm
new file mode 100644
index 0000000..79a65a7
--- /dev/null
+++ b/scheme/alt/init-defpackage.scm
@@ -0,0 +1,14 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This file should be loaded into the bootstrap linker before any use
+; of DEFINE-STRUCTURE.  Compare with env/init-defpackage.scm.
+
+(define-reflective-tower-maker
+  (lambda (clauses names)
+    (let ((env (interaction-environment)))
+      (delay
+	(begin (if (not (null? clauses))
+		   (warn "a FOR-SYNTAX clause appears in a package being linked by the cross-linker"
+			 `(for-syntax ,@clauses)))
+	       (cons eval env))))))
diff --git a/scheme/alt/jar-defrecord.scm b/scheme/alt/jar-defrecord.scm
new file mode 100644
index 0000000..e37b590
--- /dev/null
+++ b/scheme/alt/jar-defrecord.scm
@@ -0,0 +1,47 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This is JAR's define-record-type, which doesn't resemble Richard's.
+
+; There's no implicit name concatenation, so it can be defined
+; entirely using syntax-rules.  Example:
+;  (define-record-type foo :foo
+;    (make-foo x y)
+;    foo?              - predicate name is optional
+;    (x foo-x)
+;    (y foo-y)
+;    (z foo-z set-foo-z!))
+
+(define-syntax define-record-type
+  (syntax-rules ()
+    ((define-record-type ?id ?type
+       (?constructor ?arg ...)
+       (?field . ?field-stuff)
+       ...)
+     (begin (define ?type (make-record-type '?id '(?field ...)))
+	    (define ?constructor (record-constructor ?type '(?arg ...)))
+	    (define-accessors ?type (?field . ?field-stuff) ...)))
+    ((define-record-type ?id ?type
+       (?constructor ?arg ...)
+       ?pred
+       ?more ...)
+     (begin (define-record-type ?id ?type
+	      (?constructor ?arg ...)
+	      ?more ...)
+	    (define ?pred (record-predicate ?type))))))
+
+; Straightforward version
+(define-syntax define-accessors
+  (syntax-rules ()
+    ((define-accessors ?type ?field-spec ...)
+     (begin (define-accessor ?type . ?field-spec) ...))))
+
+(define-syntax define-accessor
+  (syntax-rules ()
+    ((define-accessor ?type ?field ?accessor)
+     (define ?accessor (record-accessor ?type '?field)))
+    ((define-accessor ?type ?field ?accessor ?modifier)
+     (begin (define ?accessor (record-accessor ?type '?field))
+	    (define ?modifier (record-modifier ?type '?field))))
+    ((define-accessor ?type ?field)
+     (begin))))
diff --git a/scheme/alt/locations.scm b/scheme/alt/locations.scm
new file mode 100644
index 0000000..5b4a384
--- /dev/null
+++ b/scheme/alt/locations.scm
@@ -0,0 +1,31 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Locations
+
+(define location-rtd
+  (make-record-type 'location '(id defined? contents)))
+
+(define-record-discloser location-rtd
+  (lambda (l) `(location ,(location-id l))))
+
+(define make-undefined-location
+  (let ((make (record-constructor location-rtd
+				  '(id defined? contents))))
+    (lambda (id)
+      (make id #f '*empty*))))
+
+(define location? (record-predicate location-rtd))
+(define location-id        (record-accessor location-rtd 'id))
+(define set-location-id!   (record-modifier location-rtd 'id))
+(define location-defined?  (record-accessor location-rtd 'defined?))
+(define contents  (record-accessor location-rtd 'contents))
+
+(define set-defined?! (record-modifier location-rtd 'defined?))
+
+(define (set-location-defined?! loc ?)
+  (set-defined?! loc ?)
+  (if (not ?)
+      (set-contents! loc '*empty*)))
+
+(define set-contents!		(record-modifier location-rtd 'contents))
diff --git a/scheme/alt/loophole.scm b/scheme/alt/loophole.scm
new file mode 100644
index 0000000..d8d7a96
--- /dev/null
+++ b/scheme/alt/loophole.scm
@@ -0,0 +1,9 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+(define-syntax loophole
+  (syntax-rules ()
+    ((loophole ?type ?form)
+     (begin (lambda () ?type)    ;Elicit unbound-variable warnings, etc.
+	    ?form))))
+    
diff --git a/scheme/alt/low-packages.scm b/scheme/alt/low-packages.scm
new file mode 100644
index 0000000..18f53a3
--- /dev/null
+++ b/scheme/alt/low-packages.scm
@@ -0,0 +1,28 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Alternate implementations of the low-structures.
+; Cf. low-structures-interface in ../packages.scm and ../alt-structures.scm.
+
+; Most of the low-structures are assumed to be inherited or obtained
+; elsewhere (probably from a running Scheme 48).  This only defines
+; structures that export privileged operations.
+
+(define-structure escapes escapes-interface
+  (open scheme-level-2 define-record-types signals)
+  (files escape))
+
+(define-structures ((primitives primitives-interface)
+		    (primitives-internal (export maybe-handle-interrupt
+						 raise-exception
+						 get-exception-handler
+						 ?start)))
+  (open scheme-level-2
+	define-record-types
+	bitwise	    ;Only for re-export
+	features    ;Only for re-export
+	signals
+	;; templates -- unneeded now?
+	)
+  (files primitives
+	 weak
+	 contin))
diff --git a/scheme/alt/low.scm b/scheme/alt/low.scm
new file mode 100644
index 0000000..1628da1
--- /dev/null
+++ b/scheme/alt/low.scm
@@ -0,0 +1,25 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Portable versions of low-level things that would really like to rely
+; on the Scheme 48 VM or on special features provided by the byte code
+; compiler.
+
+(define (vector-unassigned? v i) #f)
+
+(define (flush-the-symbol-table!) #f)
+
+(define maybe-open-input-file open-input-file)
+(define maybe-open-output-file open-output-file)
+
+
+; Suppress undefined export warnings.
+
+(define-syntax %file-name%
+  (syntax-rules ()
+    ((%file-name%) "")))
+
+(define-syntax structure-ref
+  (syntax-rules ()
+    ((structure-ref ?struct ?name)
+     (error "structure-ref isn't implemented" '?struct '?name))))
diff --git a/scheme/alt/primitives.scm b/scheme/alt/primitives.scm
new file mode 100644
index 0000000..e52964e
--- /dev/null
+++ b/scheme/alt/primitives.scm
@@ -0,0 +1,181 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Alternate implementation of PRIMITIVES module.
+
+(define underlying-error error)
+
+(define (unspecific) (if #f #f))
+
+
+; Records
+
+(define-record-type new-record :new-record
+  (make-new-record fields)
+  record?
+  (fields new-record-fields))
+
+(define (make-record size init)
+  (make-new-record (make-vector size init)))
+
+(define (record-ref r i)
+  (vector-ref (new-record-fields r) i))
+
+(define (record-set! r i value)
+  (vector-set! (new-record-fields r) i value))
+
+(define (record-length r)
+  (vector-length (new-record-fields r)))
+
+
+; Extended numbers
+
+(define-record-type new-extended-number :new-extended-number
+  (make-new-extended-number fields)
+  extended-number?
+  (fields new-extended-number-fields))
+
+(define-record-discloser :new-extended-number
+  (lambda (n) `(extended-number ,(new-extended-number-fields n))))
+
+(define (make-extended-number size init)
+  (make-new-extended-number (make-vector size init)))
+
+(define (extended-number-ref n i)
+  (vector-ref (new-extended-number-fields n) i))
+
+(define (extended-number-set! n i value)
+  (vector-set! (new-extended-number-fields n) i value))
+
+(define (extended-number-length n)
+  (vector-length (new-extended-number-fields n)))
+
+
+; Current thread
+
+(define *current-thread* 'uninitialized-current-thread)
+(define (current-thread) *current-thread*)
+(define (set-current-thread! thread)
+  (if (not (and (record? thread)
+		(list? (record-ref thread 1))))
+      (underlying-error "invalid current thread" thread))
+  (set! *current-thread* thread))
+
+; Etc.
+
+(define (close-port port)
+  ((if (input-port? port) close-input-port close-output-port)
+   port))
+
+(define (write-string s port)
+  (display s port))
+
+(define (write-string-tail s start port)
+  (display (substring s start (port))
+
+(define (schedule-interrupt interval)
+  (if (not (= interval 0))
+      (warn "ignoring schedule-interrupt" interval)))
+
+(define *pseudo-enabled-interrupts* 0)
+
+(define (set-enabled-interrupts! ei)
+  (let ((previous *pseudo-enabled-interrupts*))
+    (set! *pseudo-enabled-interrupts* ei)
+    ;; (if (bitwise-and *pseudo-pending-interrupts* ei) ...)
+    previous))
+
+(define *pseudo-pending-interrupts* 0)
+
+(define *pseudo-exception-handlers* #f)
+(define (set-exception-handlers! h)
+  (let ((old *pseudo-exception-handlers*))
+    (set! *pseudo-exception-handlers* h)
+    old))
+
+(define *pseudo-interrupt-handlers* #f)
+(define (set-interrupt-handlers! v)
+  (let ((old *pseudo-interrupt-handlers*))
+    (set! *pseudo-interrupt-handlers* v)
+    old))
+
+(define (unimplemented name)
+  (lambda args (underlying-error "unimplemented primitive" name args)))
+(define collect (unimplemented 'collect))
+(define external-call (unimplemented 'external-call)) 
+(define external-lookup (unimplemented 'external-lookup))
+(define external-name (unimplemented 'external-name))
+(define external-value (unimplemented 'external-value))
+(define (external? x) #f)
+(define find-all (unimplemented 'find-all))
+(define make-external (unimplemented 'make-external))
+(define vm-extension (unimplemented 'vm-extension))
+
+(define (memory-status which arg)
+  (case which
+    ((2) 100)
+    ((3) (display "(Ignoring set-minimum-recovered-space!)") (newline))
+    (else (underlying-error "unimplemented memory-status" which arg))))
+
+(define (time which arg)
+  (case which
+    ((0) 1000)
+    (else (underlying-error "unimplemented time" which arg))))
+
+
+; end of definitions implementing PRIMITIVES structure
+
+
+; --------------------
+
+; Auxiliary crud.
+
+(define (maybe-handle-interrupt which)
+  ;; Should actually do (get-highest-priority-interrupt!) ...
+  (let ((bit (arithmetic-shift 1 which)))
+    (cond ((= (bitwise-and *pseudo-enabled-interrupts* bit) 0)
+	   (set! *pseudo-pending-interrupts*
+		 (bitwise-ior *pseudo-pending-interrupts* bit))
+	   (display "(Interrupt deferred)")
+	   (newline)
+	   #f)
+	  (else
+	   (set! *pseudo-pending-interrupts*
+		 (bitwise-and *pseudo-pending-interrupts*
+			      (bitwise-not bit)))
+	   (display "(Handling interrupt)")
+	   (newline)
+	   ((vector-ref *pseudo-interrupt-handlers* which)
+	    (set-enabled-interrupts! 0))
+	   #t))))
+
+(define (raise-exception opcode exception arguments)
+  (apply (vector-ref (get-exception-handlers) opcode)
+	 (cons exception arguments)))
+
+(define (get-exception-handlers)
+  *pseudo-exception-handlers*)
+
+
+(define (clear-registers!)
+  (set! *current-thread* 'uninitialized-current-thread)
+  (set! *pseudo-enabled-interrupts* 0)
+  (set! *pseudo-interrupt-handlers* #f)
+  (set! *pseudo-exception-handlers* #f))
+
+(define *vm-return* #f)
+
+(define (vm-return . rest)
+  (if *vm-return*
+      (apply *vm-return* rest)
+      (underlying-error "vm-return" rest)))
+
+
+(define (?start entry-point arg) ;E.g. (?start (usual-resumer bare) 0)
+  (clear-registers!)
+  (call-with-current-continuation
+    (lambda (k)
+      (set! *vm-return* k)
+      (entry-point arg
+		   (current-input-port)
+		   (current-output-port)))))
diff --git a/scheme/alt/pseudoscheme-features.scm b/scheme/alt/pseudoscheme-features.scm
new file mode 100644
index 0000000..416bcc5
--- /dev/null
+++ b/scheme/alt/pseudoscheme-features.scm
@@ -0,0 +1,111 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This is file pseudoscheme-features.scm.
+; Synchronize any changes with all the other *-features.scm files.
+
+(define *load-file-type* #f) ;For fun
+
+
+; SIGNALS
+
+(define error #'ps:scheme-error)
+
+(define warn #'ps:scheme-warn)
+
+(define (signal type . stuff)
+  (apply warn "condition signalled" type stuff))
+
+(define (syntax-error . rest)		; Must return a valid expression.
+  (apply warn rest)
+  ''syntax-error)
+
+(define (call-error message proc . args)
+  (error message (cons proc args)))
+
+
+; FEATURES
+
+(define force-output #'lisp:force-output)
+
+(define (string-hash s)
+  (let ((n (string-length s)))
+    (do ((i 0 (+ i 1))
+         (h 0 (+ h (lisp:char-code (string-ref s i)))))
+        ((>= i n) h))))
+
+(define (make-immutable! thing) thing)
+(define (immutable? thing) #f)
+(define (unspecific) (if #f #f))
+
+
+; BITWISE
+
+(define arithmetic-shift #'lisp:ash)
+(define bitwise-and #'lisp:logand)
+(define bitwise-ior #'lisp:logior)
+(define bitwise-not #'lisp:lognot)
+
+
+; ASCII
+
+(define char->ascii #'lisp:char-code)
+(define ascii->char #'lisp:code-char)
+(define ascii-limit lisp:char-code-limit)
+(define ascii-whitespaces '(32 10 9 12 13))
+
+
+; CODE-VECTORS
+
+(define (make-code-vector len . fill-option)
+  (lisp:make-array len :element-type '(lisp:unsigned-byte 8)
+		       :initial-element (if (null? fill-option)
+					    0
+					    (car fill-option))))
+
+(define (code-vector? obj)
+  (ps:true? (lisp:typep obj
+			(lisp:quote (lisp:simple-array (lisp:unsigned-byte 8)
+						       (lisp:*))))))
+
+(define (code-vector-ref bv k)
+  (lisp:aref (lisp:the (lisp:simple-array (lisp:unsigned-byte 8) (lisp:*))
+		       bv)
+	     k))
+
+(define (code-vector-set! bv k val)
+  (lisp:setf (lisp:aref (lisp:the (lisp:simple-array (lisp:unsigned-byte 8)
+						     (lisp:*))
+				  bv)
+			k)
+	     val))
+
+(define (code-vector-length bv)
+  (lisp:length (lisp:the (lisp:simple-array (lisp:unsigned-byte 8) (lisp:*))
+			 bv)))
+
+
+; The rest is unnecessary in Pseudoscheme versions 2.8d and after.
+
+;(define eval #'schi:scheme-eval)
+;(define (interaction-environment) schi:*current-rep-environment*)
+;(define scheme-report-environment
+;  (let ((env (scheme-translator:make-program-env
+;              'rscheme
+;              (list scheme-translator:revised^4-scheme-module))))
+;    (lambda (n)
+;      n ;ignore
+;      env)))
+
+; Dynamic-wind.
+;
+;(define (dynamic-wind in body out)
+;  (in)
+;  (lisp:unwind-protect (body)
+;    (out)))
+;
+;(define values #'lisp:values)
+;
+;(define (call-with-values thunk receiver)
+;  (lisp:multiple-value-call receiver (thunk)))
diff --git a/scheme/alt/pseudoscheme-record.scm b/scheme/alt/pseudoscheme-record.scm
new file mode 100644
index 0000000..da46538
--- /dev/null
+++ b/scheme/alt/pseudoscheme-record.scm
@@ -0,0 +1,19 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+(define make-record-type   #'scheme-translator::make-record-type)
+(define record-constructor #'scheme-translator::record-constructor)
+(define record-accessor    #'scheme-translator::record-accessor)
+(define record-modifier    #'scheme-translator::record-modifier)
+(define record-predicate   #'scheme-translator::record-predicate)
+(define define-record-discloser #'scheme-translator::define-record-discloser)
+
+(define (record-type? x)
+  (lisp:if (scheme-translator::record-type-descriptor-p x) #t #f))
+(define record-type-field-names #'scheme-translator::rtd-field-names)
+(define record-type-name	#'scheme-translator::rtd-identification)
+
+; Internal record things, for inspector or whatever
+(define disclose-record #'scheme-translator::disclose-record)
+(define record-type #'scheme-translator::record-type)
+(define (record? x) (lisp:if (scheme-translator::record-type x) #t #f))
+
diff --git a/scheme/alt/queue.scm b/scheme/alt/queue.scm
new file mode 100644
index 0000000..fb1214c
--- /dev/null
+++ b/scheme/alt/queue.scm
@@ -0,0 +1,28 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Queues
+
+(define (make-queue)
+  (cons '() '()))
+
+(define (queue-empty? q)
+  (and (null? (car q))
+       (null? (cdr q))))
+
+(define (enqueue! q obj)
+  (set-car! q (cons obj (car q))))
+
+(define (dequeue! q)
+  (normalize-queue! q)
+  (let ((head (car (cdr q))))
+    (set-cdr! q (cdr (cdr q)))
+    head))
+
+(define (normalize-queue! q)
+  (if (null? (cdr q))
+      (begin (set-cdr! q (reverse (car q)))
+	     (set-car! q '()))))
+
+(define (queue-head q)
+  (normalize-queue! q)
+  (car (cdr q)))
diff --git a/scheme/alt/record.scm b/scheme/alt/record.scm
new file mode 100644
index 0000000..5570b11
--- /dev/null
+++ b/scheme/alt/record.scm
@@ -0,0 +1,96 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This is file record.scm.
+
+;;;; Records
+
+; This is completely vanilla Scheme code.  Should work anywhere.
+
+(define (make-record-type type-id field-names)
+
+  (define unique (list type-id))
+
+  (define size (+ (length field-names) 1))
+
+  (define (constructor . names-option)
+    (let* ((names (if (null? names-option)
+		      field-names
+		      (car names-option)))
+	   (number-of-inits (length names))
+	   (indexes (map field-index names)))
+      (lambda field-values
+	(if (= (length field-values) number-of-inits)
+	    (let ((record (make-vector size 'uninitialized)))
+	      (vector-set! record 0 unique)
+	      (for-each (lambda (index value)
+			  (vector-set! record index value))
+			indexes
+			field-values)
+	      record)
+	    (error "wrong number of arguments to record constructor"
+		   field-values type-id names)))))
+
+  (define (predicate obj)
+    (and (vector? obj)
+	 (= (vector-length obj) size)
+	 (eq? (vector-ref obj 0) unique)))
+
+  (define (accessor name)
+    (let ((i (field-index name)))
+      (lambda (record)
+	(if (predicate record) ;Faster: (eq? (vector-ref record 0) unique)
+	    (vector-ref record i)
+	    (error "invalid argument to record accessor"
+		   record type-id name)))))
+
+  (define (modifier name)
+    (let ((i (field-index name)))
+      (lambda (record new-value)
+	(if (predicate record) ;Faster: (eq? (vector-ref record 0) unique)
+	    (vector-set! record i new-value)
+	    (error "invalid argument to record modifier"
+		   record type-id name)))))
+
+  (define (field-index name)
+    (let loop ((l field-names) (i 1))
+      (if (null? l)
+	  (error "bad field name" name)
+	  (if (eq? name (car l))
+	      i
+	      (loop (cdr l) (+ i 1))))))
+
+  (define the-descriptor
+    (lambda (request)
+      (case request
+	((constructor) constructor)
+	((predicate) predicate)
+	((accessor) accessor)
+	((modifier) modifier)
+	((name) type-id)
+	((field-names) field-names))))
+
+  the-descriptor)
+
+(define (record-constructor r-t . names-option)
+  (apply (r-t 'constructor) names-option))
+
+(define (record-predicate r-t)
+  (r-t 'predicate))
+
+(define (record-accessor r-t field-name)
+  ((r-t 'accessor) field-name))
+
+(define (record-modifier r-t field-name)
+  ((r-t 'modifier) field-name))
+
+(define (record-type-name r-t) (r-t 'name))
+(define (record-type-field-names r-t) (r-t 'field-names))
+
+(define (record-type? r-t)
+  (and (procedure? r-t)
+       (error "record-type? not implemented" r-t)))
+
+(define (define-record-discloser r-t proc)
+  "ignoring define-record-discloser form")
diff --git a/scheme/alt/reroot.scm b/scheme/alt/reroot.scm
new file mode 100644
index 0000000..406ce05
--- /dev/null
+++ b/scheme/alt/reroot.scm
@@ -0,0 +1,54 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; A state space is a tree with the state at the root.  Each node other
+; than the root is a triple <before, after, parent>, represented in
+; this implementation as a structure ((before . after) . parent).
+; Moving from one state to another means re-rooting the tree by pointer
+; reversal. 
+
+(define *here* (list #f))
+
+(define original-cwcc call-with-current-continuation)
+
+(define (call-with-current-continuation proc)
+  (let ((here *here*))
+    (original-cwcc (lambda (cont)
+		     (proc (lambda results
+			     (reroot! here)
+			     (apply cont results)))))))
+
+(define (dynamic-wind before during after)
+  (let ((here *here*))
+    (reroot! (cons (cons before after) here))
+    (call-with-values during
+      (lambda results
+	(reroot! here)
+	(apply values results)))))
+
+(define (reroot! there)
+  (if (not (eq? *here* there))
+      (begin (reroot! (cdr there))
+	     (let ((before (caar there))
+		   (after (cdar there)))
+	       (set-car! *here* (cons after before))
+	       (set-cdr! *here* there)
+	       (set-car! there #f)
+	       (set-cdr! there '())
+	       (set! *here* there)
+	       (before)))))
+
+; -----
+;
+;(define r #f) (define s #f) (define (p x) (write x) (newline))
+;(define (tst)
+;  (set! r *here*)
+;  (set! s (cons (cons (lambda () (p 'in)) (lambda () (p 'out))) *here*))
+;  (reroot! s))
+;
+;
+;(define (check)                         ;Algorithm invariants
+;  (if (not (null? (cdr *here*)))
+;      (error "confusion #1"))
+;  (if (car *here*)
+;      (error "confusion #2")))
diff --git a/scheme/alt/schemetoc-features.scm b/scheme/alt/schemetoc-features.scm
new file mode 100644
index 0000000..b2fe33f
--- /dev/null
+++ b/scheme/alt/schemetoc-features.scm
@@ -0,0 +1,121 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; BUG: (+ (expt 2 28) (expt 2 28)), (* (expt 2 28) 2)
+
+(define-external schemetoc-error ;(schemetoc-error symbol format-string . args)
+  "scdebug" "error_v")
+
+(eval-when (eval)
+  (define schemetoc-error error))
+
+
+; SIGNALS
+
+(define (error message . irritants)
+  (if (symbol? message)
+      (apply schemetoc-error message irritants)
+      (apply schemetoc-error
+	     "Error:"
+	     (apply string-append
+		    message
+		    (map (lambda (x) "~%      ~s")
+			 irritants))
+	     irritants)))
+
+(define (warn message . irritants)
+  (display-error-message "Warning: " message irritants))
+
+(define (display-error-message heading message irritants)
+  (display heading)
+  (display message)
+  (newline)
+  (let ((spaces (list->string
+		 (map (lambda (c) #\space) (string->list heading)))))
+    (for-each (lambda (irritant)
+		(display spaces)
+		(write irritant)
+		(newline))
+	      irritants)))
+
+(define (signal type . stuff)
+  (apply warn "condition signalled" type stuff))
+
+(define (syntax-error . rest)		; Must return a valid expression.
+  (apply warn rest)
+  ''syntax-error)
+
+(define (call-error message proc . args)
+  (error message (cons proc args)))
+
+
+; FEATURES
+
+(define force-output flush-buffer)
+
+(define (string-hash s)
+  (let ((n (string-length s)))
+    (do ((i 0 (+ i 1))
+         (h 0 (+ h (char->ascii (string-ref s i)))))
+        ((>= i n) h))))
+
+(define (make-immutable! thing) thing)
+(define (immutable? thing) #f)
+(define (unspecific) (if #f #f))
+
+
+; BITWISE
+
+(define (arithmetic-shift x n)
+  (if (< x 0)
+      (let ((r (- -1 (arithmetic-shift (- -1 x) n))))
+	(if (> n 0)
+	    (- r (- (arithmetic-shift 1 n) 1))
+	    r))
+      (if (>= n 0)			;shift left?
+	  (if (and (<= n 8)
+		   (exact? x)
+		   (< x 4194304))
+	      (bit-lsh x n)
+	      (* x (expt 2 n)))
+	  (if (and (<= n 28) (exact? x))
+	      (bit-rsh x (- n))
+	      (floor (* x (expt 2. n)))))))
+
+(define (bitwise-and x y)
+  (if (and (< x 0) (< y 0))
+      (- -1 (bit-or (- -1 x) (- -1 y)))
+      (bit-and x y)))
+
+(define (bitwise-ior x y)
+  (if (or (< x 0) (< y 0))
+      (- -1 (bit-and (- -1 x) (- -1 y)))
+      (bit-or x y)))
+
+(define (bitwise-not x) (- -1 x))
+
+; ASCII
+
+(define char->ascii char->integer)
+(define ascii->char integer->char)
+(define ascii-limit 256)
+(define ascii-whitespaces '(32 10 9 12 13))
+
+
+; CODE-VECTORS (= alt/code-vectors.scm)
+
+(define *code-vector-marker* (list '*code-vector-marker*))
+
+(define (make-code-vector len init)
+  (let ((t (make-vector (+ len 1) init)))
+    (vector-set! t 0 *code-vector-marker*)
+    t))
+
+(define (code-vector? obj)
+  (and (vector? obj)
+       (> (vector-length obj) 0)
+       (eq? (vector-ref obj 0) *code-vector-marker*)))
+
+(define (code-vector-length t) (- (vector-length t) 1))
+(define (code-vector-ref t i) (vector-ref t (+ i 1)))
+(define (code-vector-set! t i x) (vector-set! t (+ i 1) x))
diff --git a/scheme/alt/schemetoc-record.scm b/scheme/alt/schemetoc-record.scm
new file mode 100644
index 0000000..5095e83
--- /dev/null
+++ b/scheme/alt/schemetoc-record.scm
@@ -0,0 +1,120 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This is file schemetoc-record.scm.
+; Synchronize any changes with the other *record.scm files.
+
+;;;; Records
+
+(define (make-record-type type-id field-names)
+
+  (define unique (lambda () the-descriptor))
+
+  (define size (+ (length field-names) 1))
+
+  (define (constructor . names-option)
+    (let* ((names (if (null? names-option)
+		      field-names
+		      (car names-option)))
+	   (foo (cons unique
+		      (map (lambda (name) 'uninitialized) field-names)))
+	   (number-of-inits (length names))
+	   (indexes (map field-index names)))
+      (lambda field-values
+	(if (= (length field-values) number-of-inits)
+	    (let ((record (list->%record foo)))
+	      (for-each (lambda (index value)
+			  (%record-set! record index value))
+			indexes
+			field-values)
+	      (%record-methods-set! record usual-record-methods)
+	      record)
+	    (error "wrong number of arguments to record constructor"
+		   field-values type-id names)))))
+
+  (define (predicate obj)
+    (and (%record? obj)
+	 (= (%record-length obj) size)
+	 (eq? (%record-ref obj 0) unique)))
+
+  (define (accessor name)
+    (let ((i (field-index name)))
+      (lambda (record)
+	(if (predicate record) ;Faster: (eq? (%record-ref record 0) unique)
+	    (%record-ref record i)
+	    (error "invalid argument to record accessor"
+		   record type-id name)))))
+
+  (define (modifier name)
+    (let ((i (field-index name)))
+      (lambda (record new-value)
+	(if (predicate record) ;Faster: (eq? (%record-ref record 0) unique)
+	    (%record-set! record i new-value)
+	    (error "invalid argument to record modifier"
+		   record type-id name)))))
+
+  (define (field-index name)
+    (let loop ((l field-names) (i 1))
+      (if (null? l)
+	  (error "bad field name" name)
+	  (if (eq? name (car l))
+	      i
+	      (loop (cdr l) (+ i 1))))))
+
+  (define (discloser r) (list type-id))
+
+  (define the-descriptor
+    (lambda (request)
+      (case request
+	((constructor) constructor)
+	((predicate) predicate)
+	((accessor) accessor)
+	((modifier) modifier)
+	((identification) type-id)
+	((field-names) field-names)
+	((discloser) discloser)
+	((set-discloser!) (lambda (d) (set! discloser d))))))
+
+  the-descriptor)
+
+(define (record-type x)
+  (if (%record? x)
+      (let ((probe (%record-ref x 0)))
+	(if (procedure? probe)
+	    (probe)
+	    #f))
+      #f))
+
+(define (record-type-identification r-t)
+  (r-t 'identification))
+
+(define (record-type-field-names r-t)
+  (r-t 'field-names))
+
+(define (record-constructor r-t . names-option)
+  (apply (r-t 'constructor) names-option))
+
+(define (record-predicate r-t)
+  (r-t 'predicate))
+
+(define (record-accessor r-t field-name)
+  ((r-t 'accessor) field-name))
+
+(define (record-modifier r-t field-name)
+  ((r-t 'modifier) field-name))
+
+(define (define-record-discloser r-t proc)
+  ((r-t 'set-discloser!) proc))
+
+(define (disclose-record r)
+  (((record-type r) 'discloser) r))
+
+(define usual-record-methods
+  (list (cons '%to-write
+	      (lambda (r port indent levels length seen)
+		(write-char #\# port)
+		(write-char %record-prefix-char port)
+		(list (disclose-record r))))))
+
+(set! %record-prefix-char #\~)
diff --git a/scheme/alt/silly.scm b/scheme/alt/silly.scm
new file mode 100644
index 0000000..69e7354
--- /dev/null
+++ b/scheme/alt/silly.scm
@@ -0,0 +1,10 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+
+(define (reverse-list->string l n)
+  ;; Significantly faster than (list->string (reverse l))
+  (let ((s (make-string n #\x)))
+    (let loop ((i (- n 1)) (l l))
+      (if (< i 0) s (begin (string-set! s i (car l))
+			   (loop (- i 1) (cdr l)))))))
diff --git a/scheme/alt/syntax.scm b/scheme/alt/syntax.scm
new file mode 100644
index 0000000..9247e70
--- /dev/null
+++ b/scheme/alt/syntax.scm
@@ -0,0 +1,204 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This definition of define-syntax is appropriate for Scheme-to-C.
+
+(define-macro define-syntax
+  (lambda (form expander)
+    (expander `(define-macro ,(cadr form)
+		 (let ((transformer ,(caddr form)))
+		   (lambda (form expander)
+		     (expander (transformer form
+					    (lambda (x) x)
+					    eq?)
+			       expander))))
+	      expander)))
+
+
+; Rewrite-rule compiler (a.k.a. "extend-syntax")
+
+; Example:
+;
+; (define-syntax or
+;   (syntax-rules ()
+;     ((or) #f)
+;     ((or e) e)
+;     ((or e1 e ...) (let ((temp e1))
+;		       (if temp temp (or e ...))))))
+
+(define-syntax syntax-rules
+  (let ()
+
+    (define name? symbol?)
+
+    (define (segment-pattern? pattern)
+      (and (segment-template? pattern)
+	   (or (null? (cddr pattern))
+	       (syntax-error "segment matching not implemented" pattern))))
+
+    (define (segment-template? pattern)
+      (and (pair? pattern)
+	   (pair? (cdr pattern))
+	   (memq (cadr pattern) indicators-for-zero-or-more)))
+
+    (define indicators-for-zero-or-more (list (string->symbol "...") '---))
+
+    (lambda (exp r c)
+
+      (define %input (r '%input))     ;Gensym these, if you like.
+      (define %compare (r '%compare))
+      (define %rename (r '%rename))
+      (define %tail (r '%tail))
+      (define %temp (r '%temp))
+
+      (define rules (cddr exp))
+      (define subkeywords (cadr exp))
+
+  (define (make-transformer rules)
+    `(lambda (,%input ,%rename ,%compare)
+       (let ((,%tail (cdr ,%input)))
+	 (cond ,@(map process-rule rules)
+		 (else
+		  (syntax-error
+		   "use of macro doesn't match definition"
+		   ,%input))))))
+
+  (define (process-rule rule)
+    (if (and (pair? rule)
+	     (pair? (cdr rule))
+	     (null? (cddr rule)))
+	(let ((pattern (cdar rule))
+	      (template (cadr rule)))
+	  `((and ,@(process-match %tail pattern))
+	    (let* ,(process-pattern pattern
+				      %tail
+				      (lambda (x) x))
+		    ,(process-template template
+				       0
+				       (meta-variables pattern 0 '())))))
+	(syntax-error "ill-formed syntax rule" rule)))
+
+  ; Generate code to test whether input expression matches pattern
+
+  (define (process-match input pattern)
+    (cond ((name? pattern)
+	   (if (member pattern subkeywords)
+	       `((,%compare ,input (,%rename ',pattern)))
+	       `()))
+	  ((segment-pattern? pattern)
+	   (process-segment-match input (car pattern)))
+	  ((pair? pattern)
+	   `((let ((,%temp ,input))
+	       (and (pair? ,%temp)
+		    ,@(process-match `(car ,%temp) (car pattern))
+		    ,@(process-match `(cdr ,%temp) (cdr pattern))))))
+	  ((or (null? pattern) (boolean? pattern) (char? pattern))
+	   `((eq? ,input ',pattern)))
+	  (else
+	   `((equal? ,input ',pattern)))))
+
+  (define (process-segment-match input pattern)
+    (let ((conjuncts (process-match '(car l) pattern)))
+      (if (null? conjuncts)
+	  `((list? ,input))			;+++
+	  `((let loop ((l ,input))
+	      (or (null? l)
+		  (and (pair? l)
+		       ,@conjuncts
+		       (loop (cdr l)))))))))
+
+  ; Generate code to take apart the input expression
+  ; This is pretty bad, but it seems to work (can't say why).
+
+  (define (process-pattern pattern path mapit)
+    (cond ((name? pattern)
+	   (if (memq pattern subkeywords)
+	       '()
+	       (list (list pattern (mapit path)))))
+	  ((segment-pattern? pattern)
+	   (process-pattern (car pattern)
+			    %temp
+			    (lambda (x)	;temp is free in x
+			      (mapit (if (eq? %temp x)
+					 path ;+++
+					 `(map (lambda (,%temp) ,x)
+						 ,path))))))
+	  ((pair? pattern)
+	   (append (process-pattern (car pattern) `(car ,path) mapit)
+		   (process-pattern (cdr pattern) `(cdr ,path) mapit)))
+	  (else '())))
+
+  ; Generate code to compose the output expression according to template
+
+  (define (process-template template rank env)
+    (cond ((name? template)
+	   (let ((probe (assq template env)))
+	     (if probe
+		 (if (<= (cdr probe) rank)
+		     template
+		     (syntax-error "template rank error (too few ...'s?)"
+				   template))
+		 `(,%rename ',template))))
+	  ((segment-template? template)
+	   (let ((vars
+		  (free-meta-variables (car template) (+ rank 1) env '())))
+	     (if (null? vars)
+		 (syntax-error "too many ...'s" template)
+		 (let* ((x (process-template (car template)
+					     (+ rank 1)
+					     env))
+			(gen (if (equal? (list x) vars)
+				 x	;+++
+				 `(map (lambda ,vars ,x)
+					 ,@vars))))
+		   (if (null? (cddr template))
+		       gen		;+++
+		       `(append ,gen ,(process-template (cddr template)
+							  rank env)))))))
+	  ((pair? template)
+	   `(cons ,(process-template (car template) rank env)
+		    ,(process-template (cdr template) rank env)))
+	  (else `(quote ,template))))
+
+  ; Return an association list of (var . rank)
+
+  (define (meta-variables pattern rank vars)
+    (cond ((name? pattern)
+	   (if (memq pattern subkeywords)
+	       vars
+	       (cons (cons pattern rank) vars)))
+	  ((segment-pattern? pattern)
+	   (meta-variables (car pattern) (+ rank 1) vars))
+	  ((pair? pattern)
+	   (meta-variables (car pattern) rank
+			   (meta-variables (cdr pattern) rank vars)))
+	  (else vars)))
+
+  ; Return a list of meta-variables of given higher rank
+
+  (define (free-meta-variables template rank env free)
+    (cond ((name? template)
+	   (if (and (not (memq template free))
+		    (let ((probe (assq template env)))
+		      (and probe (>= (cdr probe) rank))))
+	       (cons template free)
+	       free))
+	  ((segment-template? template)
+	   (free-meta-variables (car template)
+				rank env
+				(free-meta-variables (cddr template)
+						     rank env free)))
+	  ((pair? template)
+	   (free-meta-variables (car template)
+				rank env
+				(free-meta-variables (cdr template)
+						     rank env free)))
+	  (else free)))
+
+  c ;ignored
+
+  ;; Kludge for Scheme 48 static linker.
+  ;; `(cons ,(make-transformer rules)
+  ;;          ',(find-free-names-in-syntax-rules subkeywords rules))
+
+  (make-transformer rules))))
diff --git a/scheme/alt/t-features.scm b/scheme/alt/t-features.scm
new file mode 100644
index 0000000..d8be299
--- /dev/null
+++ b/scheme/alt/t-features.scm
@@ -0,0 +1,118 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This is file t-features.scm.
+; Synchronize any changes with all the other *-features.scm files.
+
+; This hasn't been tested in a long time.
+
+
+(define (get-from-t name)
+  (*value t-implementation-env name))
+
+; (define error (get-from-t 'error))   - already present
+; (define warn (get-from-t 'warn))   - already present?
+
+(define (interaction-environment)
+  scheme-user-env)			;Foo
+(define scheme-report-environment
+  (let ((env (interaction-environment))) ;Isn't there a scheme-env?
+    (lambda (n) env)))
+
+(define (ignore-errors thunk)
+  '(error "ignore-errors isn't implemented"))
+
+(define force-output (get-from-t 'force-output))
+
+(define char->ascii char->integer)
+(define ascii->char integer->char)
+
+(define (string-hash s)
+  (let ((n (string-length s)))
+    (do ((i 0 (+ i 1))
+         (h 0 (+ h (char->ascii (string-ref s i)))))
+        ((>= i n) h))))
+
+;==============================================================================
+; Bitwise logical operations on integers
+
+; T's ASH doesn't work on negative numbers
+
+(define arithmetic-shift
+  (let ((fx-ashl (get-from-t 'fx-ashl))
+	(fx-ashr (get-from-t 'fx-ashr)))
+    (lambda (integer count)
+      (if (>= count 0)
+	  (fx-ashl integer count)
+	  (fx-ashr integer (- 0 count))))))
+
+; This is from Olin Shivers:
+;   (define (correct-ash n m)
+;     (cond ((or (= m 0) (= n 0)) n)
+;           ((> n 0) (ash n m))
+;           ;; shifting a negative number.
+;           ((> m 0)                     ; left shift
+;            (- (ash (- n) m)))
+;           (else                                ; right shift
+;            (lognot (ash (lognot n) m)))))
+
+(define bitwise-and (get-from-t 'fx-and))
+(define bitwise-ior (get-from-t 'fx-ior))
+
+;==============================================================================
+; Code vectors
+
+(define make-bytev         (get-from-t 'make-bytev))
+(define code-vector?       (get-from-t 'bytev?))
+(define code-vector-length (get-from-t 'bytev-length))
+(define code-vector-ref    (get-from-t 'bref-8))
+(define code-vector-set! ((get-from-t 'setter) code-vector-ref))
+
+(define (make-code-vector size . init)
+  (let ((vec (make-bytev size)))
+    (if (not (null? init))
+	(code-vector-fill! vec (car init)))
+    vec))
+
+(define (code-vector-fill! cv x)
+  (do ((i 0 (+ i 1)))
+      ((>= i (code-vector-length cv)))
+    (code-vector-set! cv i x)))
+
+;==============================================================================
+; Bug fixes and modernizations
+; I think syntax-rules will be needed, as well.
+
+; Simulate a modernized DEFINE-SYNTAX.
+
+(#[syntax define-syntax] (define-syntax name xformer)
+  `(#[syntax define-syntax] (,name . %tail%)
+       (,xformer (cons ',name %tail%)
+		 (lambda (x) x)		;rename
+		 eq?)))			;compare
+
+; T's MAKE-VECTOR and MAKE-STRING ignore their init argument.
+
+(define make-vector
+  (let ((broken-make-vector (get-from-t 'make-vector)))
+    (lambda (size . init)
+      (let ((vec (broken-make-vector size)))
+	(if (not (null? init))
+	    (vector-fill! vec (car init)))
+	vec))))
+
+(define make-string
+  (let ((make-string (get-from-t 'make-string))
+	(string-fill (get-from-t 'string-fill)))
+    (lambda (size . init-option)
+      (if (null? init-option) 
+	  (make-string size)
+	  (string-fill (make-string size) (car init-option))))))
+
+; Dynamic-wind.
+
+(define (dynamic-wind before during after)
+  (before)
+  (let ((result (during)))
+    (after)
+    result))
diff --git a/scheme/alt/t-record.scm b/scheme/alt/t-record.scm
new file mode 100644
index 0000000..1e354ec
--- /dev/null
+++ b/scheme/alt/t-record.scm
@@ -0,0 +1,57 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This is file t-record.scm.
+; Synchronize any changes with the other *record.scm files.
+
+;;;; Records
+
+(define make-record-type
+  (let ((make-stype        (*value t-standard-env 'make-stype))
+	(crawl-exhibit     (*value t-standard-env 'crawl-exhibit))
+	(exhibit-structure (*value t-standard-env 'exhibit-structure))
+	(structure-type    (*value t-standard-env 'structure-type))
+	(object-hash	   (*value t-standard-env 'object-hash))
+	(print   	   (*value t-standard-env 'print))
+	(format		   (*value t-standard-env 'format)))
+    (lambda (id names)
+      (letrec ((rtd
+		(make-stype id names
+		  (#[syntax object] #f
+		     ((crawl-exhibit self)
+		      (exhibit-structure self))
+		     ((print self port)
+		      (format port "#{Record~_~S~_~S}" id (object-hash self)))
+		     ((structure-type self) rtd)))))
+	rtd))))
+
+(define record-predicate (*value t-standard-env 'stype-predicator))
+
+(define record-accessor (*value t-standard-env 'stype-selector))
+
+(define (record-modifier rtd name)
+  (setter (record-accessor rtd name)))
+
+(define (record-constructor rtd names)
+  (let ((number-of-inits (length names))
+	(modifiers (map (lambda (name) (record-modifier rtd name))
+			names))
+	(make ((*value t-implementation-env 'stype-constructor) rtd)))
+    (lambda values
+      (let ((record (make)))
+	(let loop ((vals values)
+		   (ups modifiers))
+	  (cond ((null? vals)
+		 (if (null? ups)
+		     record
+		     (error "too few arguments to record constructor"
+			    values type-id names)))
+		((null? ups)
+		 (error "too many arguments to record constructor"
+			values type-id names))
+		(else
+		 ((car ups) record (car vals))
+		 (loop (cdr vals) (cdr ups)))))))))
+
+(define (define-record-discloser rtd proc) 'unimplemented)
diff --git a/scheme/alt/table.scm b/scheme/alt/table.scm
new file mode 100644
index 0000000..62f3544
--- /dev/null
+++ b/scheme/alt/table.scm
@@ -0,0 +1,15 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; unworthy of copyright notice
+
+(define (make-table . hash-procedure-option) (list 'table))
+
+(define (table-ref table key)
+  (let ((probe (assq key (cdr table))))
+    (if probe (cdr probe) #f)))
+
+(define (table-set! table key value)
+  (let ((probe (assq key (cdr table))))
+    (if probe
+	(set-cdr! probe value)
+	(set-cdr! table (cons (cons key value) (cdr table))))))
diff --git a/scheme/alt/template.scm b/scheme/alt/template.scm
new file mode 100644
index 0000000..f258194
--- /dev/null
+++ b/scheme/alt/template.scm
@@ -0,0 +1,21 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Templates implemented as vectors.
+
+(define *template-marker* (list '*template-marker*))
+
+(define (make-template len init)
+  (let ((t (make-vector (+ len 1) init)))
+    (vector-set! t 0 *template-marker*)
+    t))
+
+(define (template? obj)
+  (and (vector? obj)
+       (> (vector-length obj) 0)
+       (eq? (vector-ref obj 0) *template-marker*)))
+
+(define (template-length t) (- (vector-length t) 1))
+(define (template-ref t i) (vector-ref t (+ i 1)))
+(define (template-set! t i x) (vector-set! t (+ i 1) x))
diff --git a/scheme/alt/values.scm b/scheme/alt/values.scm
new file mode 100644
index 0000000..f43d02f
--- /dev/null
+++ b/scheme/alt/values.scm
@@ -0,0 +1,19 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Multiple return values
+
+(define multiple-value-token (vector 'multiple-value-token))
+
+(define (values . things)
+  (if (and (pair? things)
+	   (null? (cdr things)))
+      (car things)
+      (cons multiple-value-token things)))
+
+(define (call-with-values producer consumer)
+  (let ((things (producer)))
+    (if (and (pair? things)
+	     (eq? (car things) multiple-value-token))
+	(apply consumer (cdr things))
+	(consumer things))))
diff --git a/scheme/alt/weak.scm b/scheme/alt/weak.scm
new file mode 100644
index 0000000..64b55e5
--- /dev/null
+++ b/scheme/alt/weak.scm
@@ -0,0 +1,8 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+(define (make-weak-pointer x) (cons '<weak> x))
+(define weak-pointer-ref cdr)
+(define (weak-pointer? x)
+  (and (pair? x) (eq? (car x) '<weak>)))
+
diff --git a/scheme/bcomp/binding.scm b/scheme/bcomp/binding.scm
new file mode 100644
index 0000000..e23e107
--- /dev/null
+++ b/scheme/bcomp/binding.scm
@@ -0,0 +1,97 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Bindings: used to store bindings in packages.
+
+; Representation is #(type place operator-or-transform-or-#f [path]).
+; PLACE is a unique (to EQ?) value, usually a location.
+
+; Why aren't these records?  Because they need to be written out in
+; the initial image?
+
+(define binding? vector?)
+
+(define (binding-type b)   (vector-ref b 0))
+(define (binding-place b)  (vector-ref b 1))
+(define (binding-static b) (vector-ref b 2))
+
+(define (binding-path binding)
+  (if (= 4 (vector-length binding))
+      (vector-ref binding 3)
+      #f))
+
+(define (set-binding-place! binding place)
+  (vector-set! binding 1 place))
+
+(define (make-binding type place static)
+  (vector type place static))
+
+(define (add-path binding path)
+  (vector (binding-type binding)
+	  (binding-place binding)
+	  (binding-static binding)
+	  path))
+
+; Used when updating a package binding.
+
+(define (clobber-binding! binding type place static)
+  (vector-set! binding 0 type)
+  (if place
+      (vector-set! binding 1 place))
+  (vector-set! binding 2 static))
+
+; Return a binding that's similar to the given one, but has its type
+; replaced with the given type.
+
+(define (impose-type type binding integrate?)
+  (if (or (eq? type syntax-type)
+	  (not (binding? binding)))
+      binding
+      (make-binding (if (eq? type undeclared-type)
+			(let ((type (binding-type binding)))
+			  (if (variable-type? type)
+			      (variable-value-type type)
+			      type))
+			type)
+		    (binding-place binding)
+		    (if integrate?
+			(binding-static binding)
+			#f))))
+
+; Return a binding that's similar to the given one, but has any
+; procedure integration or other unnecesary static information
+; removed.  But don't remove static information for macros (or
+; structures, interfaces, etc.)
+
+(define (forget-integration binding)
+  (if (and (binding-static binding)
+	   (subtype? (binding-type binding) any-values-type))
+      (make-binding (binding-type binding)
+		    (binding-place binding)
+		    #f)
+      binding))
+
+; Do X and Y denote the same thing?
+
+(define (same-denotation? x y)
+  (or (eq? x y)	    ; was EQUAL? because of names, now just for nodes
+      (and (binding? x)
+	   (binding? y)
+	   (eq? (binding-place x)
+		(binding-place y)))))
+
+; Special kludge for shadowing and package mutation.
+; Ignore this on first reading.  See env/shadow.scm.
+
+(define (maybe-fix-place! binding)
+  (let ((place (binding-place binding)))
+    (if (and (location? place)
+             (vector? (location-id place)))
+        (set-binding-place! binding (follow-forwarding-pointers place))))
+  binding)
+
+(define (follow-forwarding-pointers place)
+  (let ((id (location-id place)))
+    (if (vector? id)
+        (follow-forwarding-pointers (vector-ref id 0))
+        place)))
+
diff --git a/scheme/bcomp/cenv.scm b/scheme/bcomp/cenv.scm
new file mode 100644
index 0000000..84394ae
--- /dev/null
+++ b/scheme/bcomp/cenv.scm
@@ -0,0 +1,91 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Compile-time environments
+; These are functions
+;  name -> node			; lexical variable
+;          binding              ; package variable, any syntax
+;          #f			; free
+;
+; Special names are used to retrieve various values from environments.
+
+(define (lookup cenv name)
+  (cenv name))
+
+(define (bind1 name binding cenv)
+  (lambda (a-name)
+    (if (eq? a-name name)
+	binding
+	(lookup cenv a-name))))
+
+(define (bind names bindings cenv)
+  (cond ((null? names) cenv)
+	(else
+	 (bind1 (car names)
+		(car bindings)
+		(bind (cdr names) (cdr bindings) cenv)))))
+
+(define (bindrec names cenv->bindings cenv)
+  (set! cenv (bind names
+		  (cenv->bindings (lambda (a-name) (cenv a-name)))
+		  cenv))
+  cenv)
+
+; Making the initial environment.
+;
+;  lookup : name -> binding or (binding . path) or #f
+;  define : name type [static] -> void
+;  macro-eval : form -> delay that returns (<eval> . <env>) for evaluating
+;   macro expanders
+
+(define (make-compiler-env lookup define! macro-eval package)
+  (lambda (name)
+    (cond ((eq? name funny-name/macro-eval)
+	   macro-eval)
+	  ((eq? name funny-name/define!)
+	   define!)
+	  ((eq? name funny-name/source-file-name)
+	   #f)
+	  ((eq? name funny-name/package)
+	   package)
+	  (else
+	   (lookup name)))))
+
+; EVAL function for evaluating macro expanders.
+
+(define funny-name/macro-eval (string->symbol "Eval function for macros"))
+
+(define (environment-macro-eval cenv)
+  (cenv funny-name/macro-eval))
+
+; Function for adding definitions to the outer package.
+
+(define funny-name/define! (string->symbol "Definition function"))
+
+(define (environment-define! cenv name type . maybe-value)
+  (apply (cenv funny-name/define!) name type maybe-value))
+
+; The package on which the environment is based.  This is a temporary hack
+; to keep the package-editing code working.
+
+(define funny-name/package (string->symbol "Base package"))
+
+(define (extract-package-from-environment cenv)
+  (cenv funny-name/package))
+
+; The name of the source file.
+;   This is used by the %FILE-NAME% special form,
+;   which is in turn used by the (MODULE ...) form to save the current file in
+;    each package, 
+;   which is (finally) used to look up filenames in the correct directory.
+
+(define funny-name/source-file-name (string->symbol "Source file name"))
+
+(define (bind-source-file-name filename env)
+  (if filename
+      (bind1 funny-name/source-file-name filename env)
+      env))
+
+(define (source-file-name cenv)
+  (cenv funny-name/source-file-name))
+
+
diff --git a/scheme/bcomp/comp-exp.scm b/scheme/bcomp/comp-exp.scm
new file mode 100644
index 0000000..3bef4da
--- /dev/null
+++ b/scheme/bcomp/comp-exp.scm
@@ -0,0 +1,697 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Compiling expressions.
+
+; This is a two-phase compiler.  The first phase does macro expansion,
+; variable resolution, and instruction selection, and computes the
+; size of the code vector.  The second phase (assembly) creates the
+; code vector, "template" (literals vector), and debugging data
+; structures.
+
+; The output of the first phase (the COMPILE- and INSTRUCTION-
+; routines) and the input to the second phase (SEGMENT->TEMPLATE) is a
+; "segment."  A segment is a pair (size . proc) where size is the size
+; of the code segment in bytes, and proc is a procedure that during
+; phase 2 will store the segment's bytes into the code vector.
+
+; Optimizations are marked with +++, and may be flushed if desired.
+
+(define (compile-expression node depth cont)
+  (compile node 0 depth cont))
+
+; Main dispatch for compiling a single expression.
+
+(define (compile node level depth cont)
+  (let ((node (type-check node)))
+    ((operator-table-ref compilators (node-operator-id node))
+     node
+     level
+     depth
+     cont)))
+
+; Specialists
+
+(define compilators
+  (make-operator-table
+    (lambda (node level depth cont)
+      (generate-trap cont
+		     "not valid in expression context"
+		     (schemify node)))))
+
+(define (define-compilator name type proc)
+  (operator-define! compilators name type proc))
+
+(define-compilator 'literal 'leaf
+  (lambda (node level depth cont)
+    (let ((obj (node-form node)))
+      (if (eq? obj #f)
+	  ;; +++ hack for bootstrap from Schemes that don't distinguish #f/()
+	  (deliver-value (instruction (enum op false)) cont)
+	  (compile-constant obj depth cont)))))
+
+(define-compilator 'unspecific (proc () unspecific-type)
+  (lambda (node level depth cont)
+    (deliver-value (instruction (enum op unspecific))
+		   cont)))
+
+(define-compilator 'unassigned (proc () unspecific-type)
+  (lambda (node level depth cont)
+    (deliver-value (instruction (enum op unassigned))
+		   cont)))
+
+(define-compilator 'quote syntax-type
+  (lambda (node level depth cont)
+    (let ((exp (node-form node)))
+      level				;ignored
+      (let ((obj (cadr exp)))
+	(compile-constant obj depth cont)))))
+
+(define (compile-constant obj depth cont)
+  (if (ignore-values-cont? cont)
+      empty-segment			;+++ dead code
+      (deliver-value (instruction-with-literal (enum op literal) obj)
+		     cont)))
+
+; Variable reference
+
+(define-compilator 'name 'leaf
+  (lambda (node level depth cont)
+    (let* ((binding (name-node-binding node))
+	   (name (node-form node)))
+      (deliver-value
+         (if (pair? binding)
+	     (let ((back (- level (car binding)))
+		   (over (cdr binding)))
+	       (if (or (>= back byte-limit)
+		       (>= over byte-limit))
+		   (instruction (enum op big-local)
+				(high-byte back)
+				(low-byte back)
+				(high-byte over)
+				(low-byte over))
+		   (case back
+		     ((0) (instruction (enum op local0) over)) ;+++
+		     ((1) (instruction (enum op local1) over)) ;+++
+		     ((2) (instruction (enum op local2) over)) ;+++
+		     (else (instruction (enum op local) back over)))))
+	     (instruction-with-location (enum op global)
+					binding
+					name
+					value-type))
+	 cont))))
+
+; Assignment
+
+(define-compilator 'set! syntax-type
+  (lambda (node level depth cont)
+    (let* ((exp (node-form node))
+	   (lhs-node (cadr exp))
+	   (name (node-form lhs-node))
+	   ;; Error if not a name node...
+	   (binding (name-node-binding lhs-node)))
+      (sequentially
+       (compile (caddr exp) level depth (named-cont name))
+       (deliver-value
+	(if (pair? binding)
+	    (let ((back (- level (car binding)))
+		  (over (cdr binding)))
+	      (instruction (enum op set-local!)
+			   (high-byte back)
+			   (low-byte back)
+			   (high-byte over)
+			   (low-byte over)))
+	    (instruction-with-location (enum op set-global!)
+				       binding
+				       name
+				       usual-variable-type))
+	cont)))))
+
+; Conditional
+
+(define-compilator 'if syntax-type
+  (lambda (node level depth cont)
+    (let ((exp (node-form node))
+	  (alt-label (make-label))
+	  (join-label (make-label)))
+      (sequentially
+       ;; Test
+       (compile (cadr exp) level depth (fall-through-cont node 1))
+       (instruction-using-label (enum op jump-if-false) alt-label)
+       ;; Consequent
+       (compile (caddr exp) level depth cont)
+       (if (fall-through-cont? cont)
+	   (instruction-using-label (enum op jump) join-label)
+	   empty-segment)
+       ;; Alternate
+       (attach-label alt-label
+		     (compile (cadddr exp) level depth cont))
+       (attach-label join-label
+		     empty-segment)))))
+
+(define-compilator 'begin syntax-type
+  (lambda (node level depth cont)
+    (let ((exp-list (cdr (node-form node))))
+      (if (null? exp-list)
+	  (generate-trap cont "null begin")
+	  (let ((dummy
+		 (make-node operator/begin ;For debugging database
+			    `(begin ,@exp-list))))
+	    (let loop ((exp-list exp-list) (i 1))
+	      (if (null? (cdr exp-list))
+		  (compile (car exp-list) level depth cont)
+		  (sequentially
+		    (compile (car exp-list) level depth
+			     (ignore-values-cont dummy i))
+		    (loop (cdr exp-list) (+ i 1))))))))))
+
+; Compile a call
+
+(define (compile-call node level depth cont)
+  (if (node-ref node 'type-error)
+      (compile-unknown-call node level depth cont)
+      (let ((proc-node (car (node-form node))))
+	(cond ((name-node? proc-node)
+	       (compile-name-call node proc-node level depth cont))
+	      ((and (lambda-node? proc-node)
+		    (not (n-ary? (cadr (node-form proc-node)))))
+	       (compile-redex proc-node (cdr (node-form node)) level depth cont))
+ 	      ((and (literal-node? proc-node)
+ 		    (primop? (node-form proc-node)))
+ 	       (let ((primop (node-form proc-node)))
+ 		 (if (primop-compilator primop)
+ 		     ((primop-compilator primop) node level depth cont)
+ 		     (error "compiler bug: primop has no compilator"
+ 			    primop
+ 			    (schemify node)))))
+	      (else
+	       (compile-unknown-call node level depth cont))))))
+
+(define (compile-name-call node proc-node level depth cont)
+  (let ((binding (name-node-binding proc-node)))
+    (if (binding? binding)
+	(let ((static (binding-static binding)))
+	  (cond ((primop? static)
+		 (if (primop-compilator static)
+		     ((primop-compilator static) node level depth cont)
+		     (compile-unknown-call node level depth cont)))
+		((transform? static)
+		 (let* ((form (node-form node))
+			(new (apply-inline-transform static
+						     form
+						     (node-form proc-node))))
+		   (if (eq? new form)
+		       (compile-unknown-call node level depth cont)
+		       (compile new level depth cont))))
+		(else
+		 (compile-unknown-call node level depth cont))))
+	(compile-unknown-call node level depth cont))))
+
+(define-compilator 'call 'internal compile-call)
+
+; A redex is a call of the form ((lambda (x1 ... xn) body ...) e1 ... en).
+
+(define (compile-redex proc-node args level depth cont)
+  (let* ((proc-exp (node-form proc-node))
+	 (formals (cadr proc-exp))
+	 (body (caddr proc-exp)))
+    (cond ((not (= (length formals)
+		   (length args)))
+	   (generate-trap cont
+			  "wrong number of arguments"
+			  (cons (schemify proc-node)
+				(map schemify args))))
+	  ((null? formals)
+	   (compile body level depth cont)) ;+++
+	  (else
+	   (maybe-push-continuation
+	    (sequentially 
+	     (push-all-with-names args formals level 0)
+	     (compile-lambda-code formals body level (cont-name cont)))
+	    depth
+	    cont)))))
+
+; Compile a call to a computed procedure.
+
+(define (compile-unknown-call node level depth cont)
+  (let ((exp (node-form node)))
+    (let ((call (sequentially (push-arguments node level 0)
+			      (compile (car exp)
+				       level
+				       (length (cdr exp))
+				       (fall-through-cont node 0))
+			      (let ((nargs (length (cdr exp))))
+				(if (> nargs maximum-stack-args)
+				    (instruction (enum op big-call)
+						 (high-byte nargs)
+						 (low-byte nargs))
+				    (instruction (enum op call) nargs))))))
+      (maybe-push-continuation call depth cont))))
+
+(define (maybe-push-continuation code depth cont)
+  (if (return-cont? cont) 
+      code
+      (let ((label (make-label)))
+	(sequentially (if (>= depth byte-limit)
+			  (instruction-using-label (enum op make-big-cont)
+						   label
+						   (high-byte depth)
+						   (low-byte depth))
+			  (instruction-using-label (enum op make-cont)
+						   label
+						   depth))
+		      (if (keep-source-code?)
+			  (note-source-code (fixup-source (cont-source-info cont))
+					    code)
+			  code)
+		      (attach-label label
+				    (cont-segment cont))))))
+
+(define (fixup-source info)
+  ;; Abbreviate this somehow?
+  (if (pair? info)
+      (cons (car info)
+	    (schemify (cdr info)))
+      ;; Name might be generated...
+      info))
+
+; Continuation is implicitly fall-through.
+
+(define (push-arguments node level depth)
+  (let recur ((args (cdr (node-form node))) (depth depth) (i 1))
+    (if (null? args)
+	empty-segment
+	(sequentially (compile (car args) level depth
+			       (fall-through-cont node i))
+		      (instruction (enum op push))
+		      (recur (cdr args) (+ depth 1) (+ i 1))))))
+
+(define (push-all-with-names exp-list names level depth)
+  (if (null? exp-list)
+      empty-segment
+      (sequentially (compile (car exp-list)
+			     level depth
+			     (named-cont (node-form (car names))))
+		    (instruction (enum op push))
+                    (push-all-with-names (cdr exp-list)
+					 (cdr names)
+					 level
+					 (+ depth 1)))))
+     
+; OK, now that you've got all that under your belt, here's LAMBDA.
+
+(define-compilator 'lambda syntax-type
+  (lambda (node level depth cont)
+    (let ((exp (node-form node))
+	  (name (cont-name cont)))
+      (deliver-value
+       (sequentially
+	 (instruction (enum op closure))
+	 (template (compile-lambda exp level #f)
+		   (if (name? name)
+		       (name->symbol name)
+		       #f))
+	 (instruction 0)) ; last byte of closure instruction, 0 means use
+                          ; *env* for environment
+       cont))))
+
+(define (compile-lambda exp level body-name)
+  (let* ((formals (cadr exp))
+	 (nargs (number-of-required-args formals))
+	 (fast-protocol? (and (<= nargs maximum-stack-args)
+			      (not (n-ary? formals)))))
+    (sequentially
+     ;; Insert protocol
+     (cond (fast-protocol?
+	    (instruction (enum op protocol) nargs))
+	   ((<= nargs available-stack-space)
+	    (instruction (enum op protocol)
+			 (if (n-ary? formals)
+			     two-byte-nargs+list-protocol
+			     two-byte-nargs-protocol)
+			 (high-byte nargs)
+			 (low-byte nargs)))
+	   (else
+	    (error "compiler bug: too many formals"
+		   (schemify exp))))
+     (compile-lambda-code formals (caddr exp) level body-name))))
+
+; name isn't the name of the procedure, it's the name to be given to
+; the value that the procedure will return.
+
+(define (compile-lambda-code formals body level name)
+  (if (null? formals)		;+++ Don't make null environment
+      (compile body level 0 (return-cont name))
+      ;; (if (node-ref node 'no-inferior-lambdas) ...)
+      (sequentially
+       (let* ((nargs (number-of-required-args formals))
+	      (nargs (if (n-ary? formals)
+			 (+ nargs 1)
+			 nargs)))
+	 (instruction (enum op make-env)
+		      (high-byte nargs)
+		      (low-byte nargs)))
+       (let ((vars (normalize-formals formals))
+	     (level (+ level 1)))
+	 (set-lexical-offsets! (reverse vars) level)
+	 (note-environment
+	  (map name-node->symbol vars)
+	  (compile body level 0 (return-cont name)))))))
+
+(define (name-node->symbol node)
+  (let ((form (node-form node)))
+    (cond ((name? form)
+	   (name->symbol form))
+	  ((symbol? form)
+	   form)
+	  (else
+	   #f))))
+
+; Give each name node in NAMES a binding record that has the names lexical
+; level and offset.
+
+(define (set-lexical-offsets! names level)
+  (let loop ((over 1) (names names))
+    (if (not (null? names))
+	(begin
+	  (node-set! (car names) 
+		     'binding
+		     (cons level over))
+	  (loop (+ over 1) (cdr names))))))
+
+(define-compilator 'flat-lambda syntax-type
+  (lambda (node level depth cont)
+    (let ((exp (node-form node))
+	  (name (cont-name cont)))
+      (let ((vars (cadr exp))
+	    (free (caddr exp))
+ 	    (body (cadddr exp)))
+ 	(deliver-value (compile-flat-lambda name vars body free level)
+ 		       cont)))))
+ 
+; The MAKE-FLAT-ENV instruction is designed to allow us to make nested flat
+; environments (i.e. flat environments consisting of a linked chain of vectors)
+; but this code doesn't generate them.  The nested environments would avoid
+; the need for offsets larger than a byte.  The current code cannot handle
+; large environments.
+; When we're done we have to restore the old locations of the free variables.
+
+(define (compile-flat-lambda name vars body free level)
+  (let* ((alist (sort-list (get-variables-offsets free level)
+			   (lambda (p1 p2)
+			     (< (cadr p1)
+				(cadr p2)))))
+	 (free (map car alist))
+	 (old-locations (map name-node-binding free)))
+    (set-lexical-offsets! free 0)  ; 0 is the level
+    (let ((code (sequentially
+		 (instruction (enum op false)) ; either the super env or the env
+		 (if (null? free)
+		     empty-segment
+		     (apply instruction (enum op make-flat-env)
+			    1   ; add in *val*
+			    (+ (length free) 1)
+			    (variable-env-data (map cdr alist))))
+		 (instruction (enum op closure))
+		 (note-environment (reverse (map node-form free))
+				   (template (compile-lambda `(lambda ,vars
+								,body)
+							     0
+							     #f)
+					     (if (name? name)
+						 (name->symbol name)
+						 #f)))
+		 (instruction 1)))) ; last byte of closure instruction, 1 means
+                                    ; use *val* as environment, instead of *env*
+      (for-each (lambda (node location)
+		  (node-set! node 'binding location))
+		free
+		old-locations)
+      code)))
+
+; Looks up VARS in CENV and returns an alist of (<name> . (<level> <over>))
+; pairs.
+
+(define (get-variables-offsets vars level)
+  (let loop ((vars vars) (locs '()))
+    (if (null? vars)
+	locs
+	(let ((binding (name-node-binding (car vars))))
+	  (if (pair? binding)
+	      (let ((back (- level (car binding)))
+		    (over (cdr binding)))
+		(if (< byte-limit over)
+		    (error "lexical environment limit exceeded; complain to implementors"))
+		(loop (cdr vars)
+		      (cons (cons (car vars)
+				  (cons back over))
+			    locs)))
+	      (error "variable in flat-lambda list is not local"
+		     (car vars)))))))
+
+; Addresses is a list of (level . over) pairs, sorted by level.
+; This returns the reverse of the following data:
+;   <back for level>
+;   <number of variables from this level>
+;   <over of 1st var> ...
+;   <back for next level>
+;   ...
+; If a <back> is too large we insert some empty levels.
+
+(define (variable-env-data addresses)
+  (let level-loop ((addresses addresses) (last-level 0) (data '()))
+    (if (null? addresses)
+	(reverse data)
+	(let ((level (caar addresses)))
+	  (let loop ((addresses addresses) (overs '()))
+	    (if (or (null? addresses)
+		    (not (= level (caar addresses))))
+		(level-loop addresses
+			    level
+			    (append overs
+				    (list (length overs))
+				    (let loop ((delta (- level last-level))
+					       (back '()))
+				      (if (<= delta byte-limit)
+					  (cons delta back)
+					  (loop (- delta byte-limit)
+						`(0 ,byte-limit . ,back))))
+				    data))
+		(loop (cdr addresses)
+		      (cons (cdar addresses) overs))))))))
+	  
+; We should probably just use the sort from big-scheme.
+
+(define (sort-list xs less?)
+  (letrec ((insert (lambda (x xs)
+		     (if (null? xs)
+			 (list x)
+			 (if (less? (car xs) x)
+			     (cons (car xs)
+				   (insert x (cdr xs)))
+			     (cons x xs))))))
+    (let sort ((xs xs))    
+      (if (null? xs)
+	  '()
+	  (insert (car xs)
+		  (sort (cdr xs)))))))
+
+; LETREC.
+
+(define-compilator 'letrec syntax-type
+  (lambda (node level depth cont)
+    ;; (if (node-ref node 'pure-letrec) ...)
+    (let* ((exp (node-form node))
+	   (specs (cadr exp))
+	   (body (caddr exp))
+	   (body (make-node operator/begin
+			    `(begin
+			       ,@(map (lambda (spec)
+					(make-node operator/set!
+						   `(set! ,@spec)))
+				      specs)
+			       ,body))))
+      (if (null? specs)
+	  (compile body level depth cont) ;+++
+	  (maybe-push-continuation
+	    (sequentially
+	      (apply sequentially
+		     (map (lambda (spec)
+			    (sequentially
+			      (instruction (enum op unassigned))
+			      (instruction (enum op push))))
+			  specs))
+	      (compile-lambda-code (map car specs) body level (cont-name cont)))
+	    depth
+	    cont)))))
+
+; --------------------
+; Compile-time continuations
+;
+; A compile-time continuation is a pair (segment . source-info).
+; Segment is one of the following:
+;   a return instruction - invoke the current full continuation.
+;   empty-segment - fall through to subsequent instructions.
+;   an ignore-values instruction - ignore values, then fall through.
+; Source-info is one of:
+;   #f - we don't know anything
+;   symbol - value delivered to subsequent instructions will be assigned to
+;     a variable with this name.  If the value being assigned is a lambda, we
+;     can give that lambda that name.
+;   (i . node) - the value being computed is the i'th subexpression of the node.
+
+(define (make-cont seg source-info) (cons seg source-info))
+(define cont-segment car)
+(define cont-source-info cdr)
+
+; We could probably be able to optimize jumps to jumps.
+;(define (make-jump-cont label cont)
+;  (if (fall-through-cont? cont)
+;      (make-cont label (cont-name cont))
+;      cont))
+
+(define return-cont-segment (instruction (enum op return)))
+
+(define (return-cont name)
+  (make-cont return-cont-segment name))
+
+(define (return-cont? cont)
+  (eq? (cont-segment cont) return-cont-segment))
+
+; Fall through into next instruction while compiling the I'th part of NODE.
+
+(define (fall-through-cont node i)
+  (make-cont empty-segment (cons i node)))
+
+(define (fall-through-cont? cont)
+  (not (return-cont? cont)))
+
+; Ignore return value, then fall through
+
+(define ignore-values-segment
+  (instruction (enum op ignore-values)))
+
+(define (ignore-values-cont node i)
+  (make-cont ignore-values-segment (cons i node)))
+
+(define (ignore-values-cont? cont)
+  (eq? (cont-segment cont) ignore-values-segment))
+
+; Value is in *val*; deliver it to its continuation.
+; No need to generate an ignore-values instruction in this case.
+
+(define (deliver-value segment cont)
+  (if (ignore-values-cont? cont)	;+++
+      segment
+      (sequentially segment (cont-segment cont))))
+
+; For putting names to lambda expressions:
+
+(define (named-cont name)
+  (make-cont empty-segment name))
+
+(define (cont-name cont)
+  (if (pair? (cont-source-info cont))
+      #f
+      (cont-source-info cont)))
+
+; Find lookup result that was cached by classifier
+
+(define (name-node-binding node)
+  (or (node-ref node 'binding)
+      (node-form node)))
+
+; --------------------
+; Utilities
+
+; Produce something for source code that contains a compile-time error.
+
+(define (generate-trap cont . stuff)
+  (apply warn stuff)
+  (sequentially (instruction-with-literal (enum op literal)
+					  (cons 'error stuff))
+		(deliver-value (instruction (enum op trap))
+			       cont)))
+
+; --------------------
+; Type checking.  This gets called on all nodes.
+
+(define (type-check node)
+  (if *type-check?*
+      (let ((form (node-form node)))
+	(if (pair? form)
+	    (let ((proc-node (car form)))
+	      (if (node? proc-node)
+		  (let ((proc-type (node-type proc-node)))
+		    (cond ((procedure-type? proc-type)
+			   (if (restrictive? proc-type)
+			       (let* ((args (cdr form))
+				      (args-type (make-some-values-type
+						  (map (lambda (arg)
+							 (meet-type
+							  (node-type arg)
+							  value-type))
+						       args)))
+				      (node (make-similar-node node
+							       (cons proc-node
+								     args))))
+				 (if (not (meet? args-type
+						 (procedure-type-domain proc-type)))
+				     (diagnose-call-error node proc-type))
+				 node)
+			       node))
+			  ((not (meet? proc-type any-procedure-type))
+			   ;; Could also check args for one-valuedness.
+			   (let ((message "non-procedure in operator position"))
+			     (warn message
+				   (schemify node)
+				   `(procedure: ,proc-type))
+			     (node-set! node 'type-error message))
+			   node)
+			  (else node)))
+		  node))
+	    node))
+      node))
+
+(define (set-type-check?! check?)
+  (set! *type-check?* check?))
+
+(define *type-check?* #t)
+
+
+(define (diagnose-call-error node proc-type)
+  (let ((message
+	 (cond ((not (fixed-arity-procedure-type? proc-type))
+		"invalid arguments")
+	       ((= (procedure-type-arity proc-type)
+		   (length (cdr (node-form node))))
+		"argument type error")
+	       (else
+		"wrong number of arguments"))))
+    (warn message
+	  (schemify node)
+	  `(procedure wants:
+		      ,(rail-type->sexp (procedure-type-domain proc-type)
+					#f))
+	  `(arguments are: ,(map (lambda (arg)
+				   (type->sexp (node-type arg) #t))
+				 (cdr (node-form node)))))
+    (node-set! node 'type-error message)))
+
+
+; Type system loophole
+
+(define-compilator 'loophole syntax-type
+  (lambda (node level depth cont)
+    (compile (caddr (node-form node)) level depth cont)))
+
+; Node predicates and operators.
+
+(define lambda-node?  (node-predicate 'lambda syntax-type))
+(define name-node?    (node-predicate 'name 'leaf))
+(define literal-node? (node-predicate 'literal 'leaf))
+
+(define operator/lambda     (get-operator 'lambda syntax-type))
+(define operator/set!	    (get-operator 'set!   syntax-type))
+(define operator/call	    (get-operator 'call   'internal))
+(define operator/begin      (get-operator 'begin  syntax-type))
diff --git a/scheme/bcomp/comp-package.scm b/scheme/bcomp/comp-package.scm
new file mode 100644
index 0000000..b62cc32
--- /dev/null
+++ b/scheme/bcomp/comp-package.scm
@@ -0,0 +1,92 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; package -> template
+
+(define (compile-package package)
+  (let ((template (compile-forms ((get-optimizer
+				     (package-optimizer-names package))
+				    (expand-package package)
+				    package)
+				 (package-name package))))
+    (link! template package #t)		; #t means warn about undefined variables
+    template))
+
+; First we map down the FORMS+FILES, adding the filenames to ENV and
+; scanning the forms.  Then we walk down the list of scanned forms and
+; expand all the macros.
+;
+; All of the reversing in the second step makes it so that we process the
+; forms in there original order, to keep any errors or warnings in as
+; appropriate an order as possible, and then return them in their original
+; order.
+
+(define (expand-package package)
+  (let ((env (package->environment package)))
+    (call-with-values
+     (lambda ()
+       (package-source package))
+     (lambda (forms+files transforms needs-primitives?)
+       (for-each (lambda (name)
+		   (define-usual-transform env name))
+		 transforms)
+       (let ((scanned+envs
+	      (map (lambda (forms+file)
+		     (let ((filename (car forms+file))
+			   (forms (cdr forms+file)))
+		       (let ((env (bind-source-file-name filename env)))
+			 (cons env
+			       (scan-forms forms env)))))
+		   (if needs-primitives?
+		       `((#f . ,(define-primitives env))
+			 . ,forms+files)
+		       forms+files))))
+	 (reverse 
+	  (fold (lambda (scanned+env expanded)
+		  (let ((env (car scanned+env)))
+		    (fold (lambda (form expanded)
+			    (cons (delay (expand-scanned-form form env))
+				  expanded))
+			  (cdr scanned+env)
+			  expanded)))
+		scanned+envs
+		'())))))))
+		       
+; NAME is the name of one of the usual Scheme macros (AND, OR, COND, and so
+; forth).  This adds the appropriate transform to ENV.
+
+(define (define-usual-transform env name)
+  (environment-define! env
+		       name
+		       syntax-type
+		       (make-transform (usual-transform name)
+				       (extract-package-from-environment env)
+				       syntax-type
+				       `(usual-transform ',name)
+				       name)))
+
+; This adds definitions of all operators to ENV and returns a list of forms
+; that define the closed-compiled versions of those operators that have such.
+
+(define (define-primitives env)
+  (let ((procs '()))
+    (table-walk (lambda (name op)
+		  (let ((type (operator-type op)))
+		    (if (not (eq? (operator-type op) 'leaf))
+			(environment-define! env name (operator-type op) op))))
+		operators-table)
+    (walk-primops (lambda (name type primop)
+		    (environment-define! env name type primop)
+		    (set! procs
+			  (cons (make-define-primitive-node name env)
+				procs))))
+    procs))
+
+(define (make-define-primitive-node name env)
+  (make-node operator/define
+	     `(define ,(expand name env)
+		,(make-node operator/primitive-procedure
+			    `(primitive-procedure ,name)))))
+
+;----------------
+(define operator/define	             (get-operator 'define syntax-type))
+(define operator/primitive-procedure (get-operator 'primitive-procedure syntax-type))
diff --git a/scheme/bcomp/comp-prim.scm b/scheme/bcomp/comp-prim.scm
new file mode 100644
index 0000000..05d24aa
--- /dev/null
+++ b/scheme/bcomp/comp-prim.scm
@@ -0,0 +1,792 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This is file cprim.scm.
+
+;;;; Compiling primitive procedures and calls to them.
+
+; (primitive-procedure name)  =>  a procedure
+
+(define-compilator 'primitive-procedure syntax-type
+  (lambda (node level depth cont)
+    (let ((name (cadr (node-form node))))
+      (deliver-value (sequentially
+		       (instruction (enum op closure))
+		       (template ((primop-closed (get-primop name)))
+				 (name->symbol (cont-name cont)))
+		       (instruction 0)) ; last byte of closure instruction
+		     cont))))
+
+; --------------------
+; Direct primitives.
+
+; The simplest kind of primitive has fixed arity, corresponds to some
+; single VM instruction, and takes its arguments in the usual way (all
+; on the stack).
+
+(define (direct-compilator type opcode)
+  (lambda (node level depth cont)
+    (let ((args (cdr (node-form node))))
+      (sequentially (if (null? args)
+                        empty-segment
+                        (push-all-but-last args level depth node))
+                    (deliver-value (instruction opcode) cont)))))
+
+(define (direct-closed-compilator opcode)
+  (lambda ()
+    (let ((arg-specs (vector-ref opcode-arg-specs opcode)))
+      (sequentially (if (pair? arg-specs)
+                        (sequentially
+                         (instruction (enum op protocol) (car arg-specs))
+                         (instruction (enum op pop)))
+                        (instruction (enum op protocol) 0))
+                    (instruction opcode)
+                    (instruction (enum op return))))))
+
+(define (nargs->domain nargs)
+  (do ((nargs nargs (- nargs 1))
+       (l '() (cons value-type l)))
+      ((= nargs 0) (make-some-values-type l))))
+
+(define (get-primop-type id arg-count)
+  (or (any (lambda (foo)
+	     (if (if (pair? (car foo))
+		     (memq id (car foo))
+		     (eq? id (car foo)))
+		 (cadr foo)
+		 #f))
+	   primop-types)
+      (procedure-type (nargs->domain arg-count)
+		      value-type
+		      #t)))
+
+; Types for various primops.
+
+(define primop-types
+  `((with-continuation
+     ,(proc (escape-type (proc () any-values-type #f))
+	    any-arguments-type))
+    (eq?
+     ,(proc (value-type value-type) boolean-type))
+    ((number? integer? rational? real? complex? char? eof-object? port?)
+     ,(proc (value-type) boolean-type))
+    (exact?
+     ,(proc (number-type) boolean-type))
+    (exact->inexact
+     ,(proc (exact-type) inexact-type))
+    (inexact->exact
+     ,(proc (inexact-type) exact-type))
+    ((exp log sin cos tan asin acos sqrt)
+     ,(proc (number-type) number-type))
+    ((atan)
+     ,(proc (number-type number-type) number-type))
+    ((floor)
+     ,(proc (real-type) integer-type))
+    ((real-part imag-part angle magnitude)
+     ,(proc (complex-type) real-type))
+    ((numerator denominator)
+     ,(proc (rational-type) integer-type))
+    ((make-polar make-rectangular)
+     ,(proc (real-type real-type) complex-type))
+    ((quotient remainder)
+     ,(proc (integer-type integer-type) integer-type))
+    ((bitwise-not)
+     ,(proc (exact-integer-type) exact-integer-type))
+    ((arithmetic-shift)
+     ,(proc (exact-integer-type exact-integer-type)
+	    exact-integer-type))
+    ((char=? char<?)
+     ,(proc (char-type char-type) boolean-type))
+    (char->ascii
+     ,(proc (char-type) exact-integer-type))
+    (ascii->char
+     ,(proc (exact-integer-type) char-type))
+    (string=?
+     ,(proc (string-type string-type) boolean-type))
+    (open-channel
+     ;; Can return #f
+     ,(proc (string-type exact-integer-type) value-type))
+    (cons
+     ,(proc (value-type value-type) pair-type))
+    (intern
+     ,(proc (string-type) symbol-type))))
+
+; Can't do I/O until the meta-types interface exports input-port-type and
+; output-port-type.
+
+; Define all the primitives that correspond to opcodes in the obvious way.
+
+(do ((opcode 0 (+ opcode 1)))
+    ((= opcode op-count))
+  (let ((arg-specs (vector-ref opcode-arg-specs opcode))
+        (name (enumerand->name opcode op)))
+    (cond ((memq name '(call-external-value return-from-interrupt return)))
+          ((null? arg-specs)
+           (let ((type (proc () value-type)))
+             (define-compiler-primitive name type
+               (direct-compilator type opcode)
+               (direct-closed-compilator opcode))))
+          ((not (number? (car arg-specs))))
+	  ((memq name '(+ * - / = < > <= >=
+			bitwise-ior bitwise-xor bitwise-and
+			make-string closed-apply)))
+          (else
+           (let ((type (get-primop-type name (car arg-specs))))
+             (define-compiler-primitive name type
+               (direct-compilator type opcode)
+               (direct-closed-compilator opcode)))))))
+
+; --------------------
+; Simple primitives are executed using a fixed instruction or
+; instruction sequence.
+
+(define (define-simple-primitive name type segment)
+  (let ((winner? (fixed-arity-procedure-type? type)))
+    (let ((nargs (if winner?
+                     (procedure-type-arity type)
+                     (error "n-ary simple primitive?!" name type))))
+      (define-compiler-primitive name type
+        (simple-compilator segment)
+        (simple-closed-compilator nargs segment)))))
+
+(define (simple-compilator segment)
+  (lambda (node level depth cont)
+    (let ((args (cdr (node-form node))))
+      (sequentially (if (null? args)
+                        empty-segment
+                        (push-all-but-last args level depth node))
+                    (deliver-value segment cont)))))
+
+(define (simple-closed-compilator nargs segment)
+  (lambda ()
+    (sequentially (instruction (enum op protocol) nargs)
+                  (instruction (enum op pop))
+                  segment
+                  (instruction (enum op return)))))
+
+(define (symbol-append . syms)
+  (string->symbol (apply string-append
+                         (map symbol->string syms))))
+
+(define (define-stob-predicate name stob-name)
+  (define-simple-primitive name
+    (proc (value-type) boolean-type)
+    (instruction (enum op stored-object-has-type?)
+                 (name->enumerand stob-name stob))))
+
+(define-stob-predicate 'byte-vector? 'byte-vector)
+(define-stob-predicate 'double? 'double)
+(define-stob-predicate 'string? 'string)
+
+; Making doubles
+
+(let ((:value (sexp->type ':value #t))
+      (:double (sexp->type ':double #t)))
+  (define-simple-primitive 'make-double
+    (proc () :double)
+    (sequentially
+      (instruction-with-literal (enum op literal) 0)
+      (instruction (enum op push))
+      (instruction-with-literal (enum op literal) 0)
+      (instruction (enum op make-stored-object) 2 (enum stob double)))))
+
+; Define primitives for record-like stored objects (e.g. pairs).
+
+(define (define-data-struct-primitives name predicate maker . slots)
+  (let* ((def-prim (lambda (name type op . stuff)
+                     (define-simple-primitive name type
+                       (apply instruction (cons op stuff)))))
+         (type-byte (name->enumerand name stob))
+         (type (sexp->type (symbol-append ': name) #t)))
+    (define-stob-predicate predicate name)
+    (if maker
+        (def-prim maker
+          (procedure-type (nargs->domain (length slots)) type #t)
+          (enum op make-stored-object)
+          (length slots)
+          type-byte))
+    (do ((i 0 (+ i 1))
+         (slots slots (cdr slots)))
+        ((null? slots))
+      (let ((slot (car slots)))
+        (if (car slot)
+            (def-prim (car slot)
+              (proc (type) value-type)
+              (enum op stored-object-ref) type-byte i))
+        (if (not (null? (cdr slot)))
+            (def-prim (cadr slot)
+              (proc (type value-type) unspecific-type)
+              (enum op stored-object-set!) type-byte i))))))
+
+(for-each (lambda (stuff)
+            (apply define-data-struct-primitives stuff))
+          stob-data)
+
+; For flat environments
+
+(let ((:value (sexp->type ':value #t))
+      (:vector (sexp->type ':vector #t)))
+  (define-simple-primitive 'make-cell
+    (proc (:value) :vector)
+    (instruction (enum op make-stored-object) 1 (enum stob vector)))
+  (define-simple-primitive 'cell-ref
+    (proc (:vector) :value)
+    (instruction (enum op stored-object-ref) (enum stob vector) 0))
+  (define-simple-primitive 'cell-set!
+    (proc (:vector :value) unspecific-type)
+    (instruction (enum op stored-object-set!) (enum stob vector) 0)))
+
+; Define primitives for vector-like stored objects.
+
+(define (define-vector-primitives name element-type make length ref set!)
+  (let* ((type-byte (name->enumerand name stob))
+         (def-prim (lambda (name type op)
+                     (define-simple-primitive name type
+                       (instruction op type-byte))))
+         (type (sexp->type (symbol-append ': name) #t)))
+    (define-stob-predicate (symbol-append name '?) name)
+    (if (not (eq? name 'vector))  ; 2nd arg to make-vector is optional
+	(def-prim (symbol-append 'make- name)
+	  (proc (exact-integer-type element-type) type)
+	  make))
+    (def-prim (symbol-append name '- 'length)
+      (proc (type) exact-integer-type)
+      length)
+    (def-prim (symbol-append name '- 'ref)
+      (proc (type exact-integer-type) element-type)
+      ref)
+    (def-prim (symbol-append name '- 'set!)
+      (proc (type exact-integer-type element-type) unspecific-type)
+      set!)))
+
+(for-each (lambda (name)
+            (define-vector-primitives name value-type
+              (enum op make-vector-object)
+              (enum op stored-object-length)
+              (enum op stored-object-indexed-ref)
+              (enum op stored-object-indexed-set!)))
+          '(vector record continuation extended-number template))
+
+; SIGNAL-CONDITION is the same as TRAP.
+
+(define-simple-primitive 'signal-condition (proc (pair-type) unspecific-type)
+  (instruction (enum op trap)))
+
+
+; (primitive-catch (lambda (cont) ...))
+
+(define-compiler-primitive 'primitive-catch
+  (proc ((proc (escape-type) any-values-type #f)) any-values-type)
+  ;; (primitive-catch (lambda (cont) ...))
+  (lambda (node level depth cont)
+    (let* ((exp (node-form node))
+           (args (cdr exp)))
+      (maybe-push-continuation
+       (sequentially (instruction (enum op current-cont))
+                     (instruction (enum op push))
+                     ;; If lambda exp, should do compile-lambda-code to
+                     ;; avoid consing closure...
+                     (compile (car args) level 1 (fall-through-cont node 1))
+                     (instruction (enum op call) 1))
+       0
+       cont)))
+  (lambda ()
+    (sequentially (instruction (enum op protocol) 1)
+                  (instruction (enum op make-env)   ;Seems unavoidable.
+			       (high-byte 1)
+			       (low-byte 1))
+                  (instruction (enum op current-cont))
+                  (instruction (enum op push))
+                  (instruction (enum op local0) 1)
+                  (instruction (enum op call) 1))))  
+
+; (call-with-values (lambda () ...producer...)
+;                   (lambda args ...consumer...))
+
+(define-compiler-primitive 'call-with-values
+  (proc ((proc () any-values-type #f)
+	 any-procedure-type)
+	any-values-type)
+  (lambda (node level depth cont)
+    (let ((args (cdr (node-form node))))
+      (let ((producer (car args))
+            (consumer (cadr args)))
+        (maybe-push-continuation
+         (sequentially (compile consumer level 0 (fall-through-cont node 2))
+                       (instruction (enum op push))
+                       (maybe-push-continuation     ; nothing maybe about it
+                        (compile-call (make-node operator/call `(,producer))
+				      level 0
+                                      (return-cont #f))
+                        1
+                        (fall-through-cont #f 0))
+                       (instruction (enum op call-with-values)))
+         depth
+         cont))))
+  (lambda ()
+    ;; producer and consumer on stack
+    (let ((label (make-label)))
+      (sequentially (instruction (enum op protocol) 2)
+                    (instruction (enum op make-env)
+				 (high-byte 2)
+				 (low-byte 2))
+                    (instruction (enum op local0) 1) ;consumer
+                    (instruction (enum op push))
+                    (instruction-using-label (enum op make-cont) label 1)
+                    (instruction (enum op local0) 2) ;producer
+                    (instruction (enum op call) 0)
+                    (attach-label label
+                                  (instruction (enum op call-with-values)))))))
+
+
+; --------------------
+; Variable-arity primitives
+
+(define (define-n-ary-compiler-primitive name result-type min-nargs
+                                         compilator closed)
+  (define-compiler-primitive name
+        (if result-type
+            (procedure-type any-arguments-type result-type #f)
+            #f)
+    (if compilator
+        (n-ary-primitive-compilator name min-nargs compilator)
+        compile-unknown-call)
+    closed))
+
+(define (n-ary-primitive-compilator name min-nargs compilator)
+  (lambda (node level depth cont)
+    (let ((exp (node-form node)))
+      (if (>= (length (cdr exp)) min-nargs)
+          (compilator node level depth cont)
+          (begin (warn "too few arguments to primitive"
+                       (schemify node))
+                 (compile-unknown-call node level depth cont))))))
+
+
+; APPLY wants the arguments on the stack, with the final list on top, and the
+; procedure in *VAL*.
+
+(define-compiler-primitive 'apply
+  (proc (any-procedure-type &rest value-type) any-values-type)
+  (n-ary-primitive-compilator 'apply 2
+    (lambda (node level depth cont)
+      (let ((exp (node-form node)))	; (apply proc arg1 arg2 arg3 rest)
+	(let* ((proc+args+rest (cdr exp))
+	       (rest+args		; (rest arg3 arg2 arg1)
+		(reverse (cdr proc+args+rest)))
+	       (args+rest+proc		; (arg1 arg2 arg3 rest proc)
+		(reverse (cons (car proc+args+rest) rest+args)))
+	       (stack-nargs (length (cdr rest+args))))
+	  (maybe-push-continuation
+	   (sequentially (push-all-but-last args+rest+proc level 0 #f)
+			 ;; Operand is number of non-final arguments
+			 (instruction (enum op apply)
+				      (high-byte stack-nargs)
+				      (low-byte stack-nargs)))
+	   depth
+	   cont)))))
+  (lambda ()
+    (sequentially (instruction (enum op protocol) args+nargs-protocol 2)
+                  (instruction (enum op closed-apply)))))
+
+; (values value1 value2 ...)
+
+(define-n-ary-compiler-primitive 'values #f 0
+  (lambda (node level depth cont)
+    (let* ((args (cdr (node-form node)))
+	   (nargs (length args)))
+      (if (= 1 nargs)
+	  (compile (car args) level depth cont)		;+++
+	  (maybe-push-continuation (sequentially (push-arguments node level 0)
+						 (instruction (enum op values)
+							      (high-byte nargs)
+							      (low-byte nargs)))
+				   depth
+				   cont))))
+  (lambda ()
+    (sequentially (instruction (enum op protocol) args+nargs-protocol 0)
+		  (instruction (enum op closed-values)))))
+
+
+; (error message irritant1 irritant2)
+;  => (trap (cons 'error (cons message (cons irritant1 (cons irritant2 '())))))
+
+(let ((cons-instruction
+       (instruction (enum op make-stored-object) 2 (enum stob pair))))
+
+  (define-n-ary-compiler-primitive 'error error-type 1
+    (lambda (node level depth cont)
+      (let ((exp (node-form node)))
+        (let ((args (cdr exp)))
+          (sequentially (instruction-with-literal (enum op literal) 'error)
+                        (instruction (enum op push))
+                        (push-arguments node level (+ depth 1))
+                        (instruction-with-literal (enum op literal) '())
+                        (apply sequentially
+                               (map (lambda (arg) cons-instruction) args))
+                        cons-instruction
+                        (deliver-value (instruction (enum op trap)) cont)))))
+    (lambda ()
+      ; stack at start is: irritants message
+      (sequentially (instruction (enum op protocol)
+				 two-byte-nargs+list-protocol
+				 0		; (high-byte 1) 
+				 1)		; (low-byte 1)
+		    (instruction (enum op pop))   ; list into *val*
+		    cons-instruction
+                    (instruction (enum op push))
+                    (instruction-with-literal (enum op literal) 'error)
+                    (instruction (enum op push))
+                    (instruction (enum op stack-ref) 1)
+                    cons-instruction
+                    (instruction (enum op trap))
+                    (instruction (enum op return))))))
+
+
+; (call-external-value external-routine arg ...)
+
+(define-n-ary-compiler-primitive 'call-external-value value-type 1
+  #f                                         ;Could be done
+  (lambda ()
+    (sequentially (instruction (enum op protocol) args+nargs-protocol 1)
+                  (instruction (enum op call-external-value))
+                  (instruction (enum op return)))))
+
+(let ((n-ary-constructor
+        (lambda (name type type-byte)
+	  (define-n-ary-compiler-primitive name type 0
+	    (lambda (node level depth cont)
+	      (let ((args (cdr (node-form node))))
+		(sequentially (if (null? args)
+				  empty-segment
+				  (push-all-but-last args level depth node))
+			      (deliver-value
+			       (instruction (enum op make-stored-object)
+					    (length args)
+					    type-byte)
+			       cont))))
+	    (lambda ()
+	      (sequentially
+	       (instruction (enum op protocol) args+nargs-protocol 0)
+	       (instruction (enum op closed-make-stored-object) type-byte)
+	       (instruction (enum op return))))))))
+  (n-ary-constructor 'vector vector-type (enum stob vector))
+  (n-ary-constructor 'record #f (enum stob record)))
+
+; READ-CHAR, PEEK-CHAR and WRITE-CHAR
+
+(let ((define-char-io
+	(lambda (id opcode type)
+	  (define-compiler-primitive id
+	    type
+	    (lambda (node level depth cont)
+	      (if (node-ref node 'type-error)
+		  (compile-unknown-call node level depth cont)
+		  (let ((args (cdr (node-form node))))
+		    (if (null? args)
+			(deliver-value (instruction opcode 1) cont)
+			(sequentially
+			 (push-all-but-last args level depth node)
+			 (deliver-value (instruction opcode 0) cont))))))
+	    (lambda ()
+	      (make-dispatch-protocol
+	        ; Zero arguments
+ 	        (sequentially
+		  (instruction opcode 1)
+		  (instruction (enum op return)))
+		; One argument
+		(sequentially
+		  (instruction (enum op pop))
+		  (instruction opcode 0)
+		  (instruction (enum op return)))
+		empty-segment
+		empty-segment))))))
+  (define-char-io 'read-char
+    (enum op read-char)
+    (proc (&opt value-type) value-type))
+  (define-char-io 'peek-char
+    (enum op peek-char)
+    (proc (&opt value-type) value-type)))
+
+(let ((define-char-io
+	(lambda (id opcode type)
+	  (define-compiler-primitive id
+	    type
+	    (lambda (node level depth cont)
+	      (if (node-ref node 'type-error)
+		  (compile-unknown-call node level depth cont)
+		  (let ((args (cdr (node-form node))))
+		    (sequentially
+		     (push-all-but-last args level depth node)
+		     (if (null? (cdr args))
+			 (deliver-value (instruction opcode 1) cont)
+			 (sequentially
+			  (deliver-value (instruction opcode 0) cont)))))))
+	    (lambda ()
+	      (make-dispatch-protocol
+	        empty-segment
+	        ; One argument
+	        (sequentially
+		  (instruction (enum op pop))
+		  (instruction opcode 1)
+		  (instruction (enum op return)))
+		; Two arguments
+	        (sequentially
+		  (instruction (enum op pop))
+		  (instruction opcode 0)
+		  (instruction (enum op return)))
+		empty-segment))))))
+  (define-char-io 'write-char
+    (enum op write-char)
+    (proc (char-type &opt value-type) unspecific-type)))
+
+; Timings in 0.47 to figure out how to handle the optional ports.
+; 
+; reading 10**6 characters (no buffer underflow)
+; empty loop    time:  3.44 seconds
+; read-char     time:  3.68 seconds    ; special primitive, exceptions
+; xread-char    time:  9.04 seconds    ; special primitive, no exceptions
+; xxread-char   time: 14.05 seconds    ; no special primitive
+; Currently, looping through a 10**6 character file takes 1.51 seconds or
+; 2.50 seconds if you count the number of characters.
+
+;----------------
+; Variable-arity arithmetic primitives.
+
+; +, *, bitwise-... take any number of arguments.
+
+(let ((define+*
+	(lambda (id opcode identity type)
+	  (define-compiler-primitive id
+	    (proc (&rest type) type)
+	    (lambda (node level depth cont)
+	      (if (node-ref node 'type-error)
+		  (compile-unknown-call node level depth cont)
+		  (let ((args (cdr (node-form node))))
+		    (cond ((null? args)
+			   (deliver-value
+			    (instruction-with-literal (enum op literal)
+						      identity)
+			    cont))
+			  ((null? (cdr args))
+			   (call-on-arg-and-id opcode identity (car args)
+					       node level depth cont))
+			  (else
+			   (call-on-args opcode args node level depth cont))))))
+	    (lambda ()
+	      (make-dispatch-protocol
+	        ; No arguments
+	        (sequentially
+		  (instruction-with-literal (enum op literal) identity)
+		  (instruction (enum op return)))
+		; One argument
+		(sequentially
+		  (instruction-with-literal (enum op literal) identity)
+		  (instruction opcode)
+		  (instruction (enum op return)))
+		; Two arguments
+		(sequentially
+		  (instruction (enum op pop))
+		  (instruction opcode)
+		  (instruction (enum op return)))
+		; More than two arguments
+		(sequentially
+		  (instruction (enum op pop))	; pop off nargs
+		  (instruction (enum op binary-reduce1))
+		  (instruction opcode)
+		  (instruction (enum op binary-reduce2))
+		  (instruction (enum op return)))))))))
+  (define+* '+ (enum op +) 0 number-type)
+  (define+* '* (enum op *) 1 number-type)
+  (define+* 'bitwise-ior (enum op bitwise-ior) 0 exact-integer-type)
+  (define+* 'bitwise-xor (enum op bitwise-xor) 0 exact-integer-type)
+  (define+* 'bitwise-and (enum op bitwise-and) -1 exact-integer-type))
+
+; = and < and so forth take two or more arguments.
+
+(let ((define=<
+	(lambda (id opcode)
+	  (define-compiler-primitive id
+	    (proc (real-type real-type &rest real-type) boolean-type)
+	    (lambda (node level depth cont)
+	      (if (node-ref node 'type-error)
+		  (compile-unknown-call node level depth cont)
+		  (let ((args (cdr (node-form node))))
+		    (if (= (length args) 2)
+			(call-on-args opcode args node level depth cont)
+			(compile-unknown-call node level depth cont)))))
+	    (lambda ()
+	      (make-dispatch-protocol
+	        empty-segment
+		empty-segment
+		; Two arguments
+		(sequentially 
+		  (instruction (enum op pop))           ; get first argument
+		  (instruction opcode)
+		  (instruction (enum op return)))
+		; More than two arguments
+		(sequentially
+		  (instruction (enum op pop))
+		  (instruction (enum op binary-reduce1))
+		  (instruction opcode)
+		  (instruction (enum op binary-comparison-reduce2))
+		  (instruction (enum op return)))))))))
+  (define=< '= (enum op =))
+  (define=< '< (enum op <))
+  (define=< '> (enum op >))
+  (define=< '<= (enum op <=))
+  (define=< '>= (enum op >=)))
+
+; Returns code to apply OPCODE to IDENTITY and ARGUMENT.
+
+(define (call-on-arg-and-id opcode identity argument node level depth cont)
+  (sequentially (instruction-with-literal (enum op literal) identity)
+		(instruction (enum op push))
+		(compile argument level (+ depth 1) (fall-through-cont node 1))
+		(deliver-value (instruction opcode) cont)))
+  
+; Returns code to redue ARGS using OPCODE.
+
+(define (call-on-args opcode args node level depth cont)
+  (let ((do-arg (lambda (arg index)
+		  (compile arg
+			   level
+			   (if (= index 1) depth (+ depth 1))
+			   (fall-through-cont node index)))))
+    (let loop ((args (cdr args)) (i 2) (code (do-arg (car args) 1)))
+      (if (null? args)
+	  (deliver-value code cont)
+	  (loop (cdr args)
+		(+ i 1)
+		(sequentially code
+			      (instruction (enum op push))
+			      (do-arg (car args) i)
+			      (instruction opcode)))))))
+
+(define op/unspecific (get-operator 'unspecific))
+(define op/literal (get-operator 'literal))
+
+; -, and / take one or two arguments.
+
+(let ((define-one-or-two
+	(lambda (id opcode default-arg)
+	  (define-compiler-primitive id
+            (proc (number-type &opt number-type) number-type)
+	    (lambda (node level depth cont)
+	      (if (node-ref node 'type-error)
+		  (compile-unknown-call node level depth cont)
+		  (let* ((args (cdr (node-form node)))
+			 (args (if (null? (cdr args))
+				   (list (make-node op/literal default-arg)
+					 (car args))
+				   args)))
+		    (sequentially
+		     (push-all-but-last args level depth node)
+		     (deliver-value (instruction opcode) cont)))))
+	    (lambda ()
+	      (make-dispatch-protocol
+	        empty-segment
+		; One argument
+ 	        (sequentially
+		  (instruction-with-literal (enum op literal) default-arg)
+		  (instruction (enum op push))
+		  (instruction (enum op stack-ref) 1)
+		  (instruction opcode)
+		  (instruction (enum op return)))
+		; Two arguments
+		(sequentially
+		  (instruction (enum op pop))
+		  (instruction opcode)
+		  (instruction (enum op return)))
+		empty-segment))))))
+  (define-one-or-two '- (enum op -) 0)
+  (define-one-or-two '/ (enum op /) 1))
+
+; make-vector and make-string take one or two arguments.
+
+(let ((define-one-or-two
+	(lambda (id op-segment default-arg default-arg-segment type)
+	  (define-compiler-primitive id
+	    type
+	    (lambda (node level depth cont)
+	      (if (node-ref node 'type-error)
+		  (compile-unknown-call node level depth cont)
+		  (let* ((args (cdr (node-form node)))
+			 (args (if (null? (cdr args))
+				   (list (car args) default-arg)
+				   args)))
+		    (sequentially
+		     (push-all-but-last args level depth node)
+		     (deliver-value op-segment cont)))))
+	    (lambda ()
+	      (make-dispatch-protocol
+	        empty-segment
+		; One argument
+ 	        (sequentially
+		  default-arg-segment
+		  op-segment
+		  (instruction (enum op return)))
+		; Two arguments
+ 	        (sequentially
+		  (instruction (enum op pop))
+		  op-segment
+		  (instruction (enum op return)))
+		empty-segment))))))
+  (define-one-or-two 'make-vector
+    (instruction (enum op make-vector-object) (enum stob vector))
+    (make-node op/unspecific '(unspecific))
+    (instruction (enum op unspecific))
+    (proc (number-type &opt value-type) vector-type))
+  (define-one-or-two 'make-string
+    (instruction (enum op make-string))
+    (make-node op/literal #\?)
+    (instruction-with-literal (enum op literal) #\?)
+    (proc (number-type &opt char-type) string-type)))
+
+; --------------------
+; Utilities
+
+(define (push-all-but-last args level depth source-info)
+  (let recur ((args args) (depth depth) (i 1))
+    (let ((first-code
+           (compile (car args) level depth (fall-through-cont source-info i))))
+      (if (null? (cdr args))
+          first-code
+          (sequentially first-code
+                        (instruction (enum op push))
+                        (recur (cdr args) (+ depth 1) (+ i 1)))))))
+
+; Building primitives that use the computed-goto provided by the
+; protocol dispatcher.
+
+(define dispatch-protocol-size
+  (segment-size (instruction (enum op protocol) nary-dispatch-protocol
+			     0 0 0 0)))
+
+(define (make-dispatch-protocol zero-args one-arg two-args three-plus-args)
+  (sequentially
+    (instruction (enum op protocol) nary-dispatch-protocol
+		 (if (= 0 (segment-size zero-args))
+		     0
+		     dispatch-protocol-size)
+		 (if (= 0 (segment-size one-arg))
+		     0
+		     (+ dispatch-protocol-size
+			(segment-size zero-args)))
+		 (if (= 0 (segment-size two-args))
+		     0
+		     (+ dispatch-protocol-size
+			(segment-size zero-args)
+			(segment-size one-arg)))
+		 (if (= 0 (segment-size three-plus-args))
+		     0
+		     (+ dispatch-protocol-size
+			(segment-size zero-args)
+			(segment-size one-arg)
+			(segment-size two-args))))
+    zero-args
+    one-arg
+    two-args
+    three-plus-args))
+
diff --git a/scheme/bcomp/comp.scm b/scheme/bcomp/comp.scm
new file mode 100644
index 0000000..3757898
--- /dev/null
+++ b/scheme/bcomp/comp.scm
@@ -0,0 +1,152 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; This is the main entry point to the compiler.  It returns a template
+; that will execute the forms (each of which is a node).
+;
+; This is written in a somewhat odd fashion to make sure that the forms are
+; not retained once they have been compiled.
+
+;(define (compile-forms forms name)
+;  (if (null? forms)
+;      (segment->template (sequentially
+;                           (instruction (enum op protocol) 0)
+;                           (deliver-value (instruction (enum op unspecific))
+;                                          (return-cont #f)))
+;                         name
+;                         #f             ;pc-in-segment
+;                         #f)            ;debug data
+;      (really-compile-forms forms
+;                            (instruction (enum op protocol) 0)
+;                            name)))
+;      
+;(define (really-compile-forms forms segment name)
+;  (if (null? (cdr forms))
+;      (segment->template (sequentially segment
+;                                       (compile-form (car forms)
+;                                                     (return-cont #f)))
+;                         name
+;                         #f             ;pc-in-segment
+;                         #f)            ;debug data
+;      (really-compile-forms (cdr forms)
+;                            (sequentially segment
+;                                          (compile-form (car forms)
+;                                                        an-ignore-values-cont))
+;                            name)))
+
+(define (compile-forms forms name)
+  (if (null? forms)
+      (segment->template (sequentially
+                           (instruction (enum op protocol) 0)
+                           (deliver-value (instruction (enum op unspecific))
+                                          (return-cont #f)))
+                         name
+                         #f             ;pc-in-segment
+                         #f)            ;debug data
+      (compile-forms-loop (reverse forms) name #f)))
+
+(define (compile-forms-loop forms name next)
+  (if (null? forms)
+      next
+      (compile-forms-loop (cdr forms)
+			  name
+			  (compile-form (car forms) name next))))
+
+; Compile a single top-level form, returning a template.  NEXT is either #F or
+; a template; if it is a template we jump to it after FORM.
+  
+(define (compile-form form name next)
+  (segment->template (sequentially
+		      (instruction (enum op protocol) 0)
+		      (let ((node (force-node form))
+			    (cont (if next
+				      an-ignore-values-cont
+				      (return-cont #f))))
+			(if (define-node? node)
+			    (compile-definition node cont)
+			    (compile-expression node 0 cont)))
+		      (if next
+			  (instruction-with-literal (enum op call-template)
+						    next
+						    0)
+			  empty-segment))
+		     name
+		     #f		;pc-in-segment
+		     #f))	;debug data
+
+(define define-node? (node-predicate 'define syntax-type))
+
+; Definitions must be treated differently from assignments: we must
+; use SET-CONTENTS! instead of SET-GLOBAL! because the SET-GLOBAL!
+; instruction traps if an attempt is made to store into an undefined
+; location.
+
+(define (compile-definition node cont)
+  (let* ((form (node-form node))
+	 (name (cadr form)))
+    (sequentially (instruction-with-location (enum op literal)
+					     (node-ref name 'binding)
+					     (node-form name)
+					     value-type)
+		  (instruction (enum op push))
+		  (compile-expression (caddr form)
+				      1
+				      (named-cont (node-form name)))
+		  (deliver-value
+		   (instruction (enum op stored-object-set!)
+				(enum stob location)
+				location-contents-offset)
+		   cont))))
+
+(define location-contents-offset
+  (cond ((assq 'location stob-data)
+	 => (lambda (stuff)
+	      (let loop ((slots (cdddr stuff)) (i 0))
+		(if (eq? (caar slots) 'contents)
+		    i
+		    (loop (cdr slots) (+ i 1))))))
+	(else
+	 (error "can't find location data in STOB-DATA"))))
+
+;----------------
+; Make a startup procedure from a list of initialization templates.  This
+; is only used by the static linker.  RESUMER should be a template that
+; returns a procedure that takes 5 arguments (the number the VM passes to
+; the startup procedure).
+
+(define (make-startup-procedure inits resumer)
+  (let ((nargs 5))
+    (append-templates inits
+		      nargs
+		      (sequentially
+		        (maybe-push-continuation
+			  (instruction-with-literal (enum op call-template)
+						    resumer
+						    0)
+			  nargs
+			  (fall-through-cont #f #f))
+			(instruction (enum op call) nargs)))))
+
+; Return a template that accepts NARGS arguments, invokes TEMPLATES in turn,
+; and then calls template FINAL on the arguments.
+
+(define (append-templates templates nargs final)
+  (segment->template
+    (sequentially
+      (instruction (enum op protocol) nargs)
+      (reduce (lambda (template seg)
+		(sequentially
+		  (maybe-push-continuation
+		    (instruction-with-literal (enum op call-template)
+					      template
+					      0)
+		    nargs
+		    an-ignore-values-cont)
+		  seg))
+	      final
+	      templates))
+    #f		; no name
+    #f		; pc-in-segment = #f
+    #f))	; no debug data
+
+(define an-ignore-values-cont (ignore-values-cont #f #f))
+
diff --git a/scheme/bcomp/config.scm b/scheme/bcomp/config.scm
new file mode 100644
index 0000000..a8f45c5
--- /dev/null
+++ b/scheme/bcomp/config.scm
@@ -0,0 +1,34 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; For DEFINE-STRUCTURE macro
+
+(define (make-a-package opens-thunk accesses-thunk tower
+			dir clauses name)
+  (make-package opens-thunk accesses-thunk
+		#t    ;unstable
+		tower
+		dir
+		clauses
+		#f
+		name))
+
+(define (loser . rest)
+  (error "init-defpackage! neglected"))
+
+(define interface-of structure-interface)
+
+(define *verify-later!* (lambda (thunk) #f))
+
+(define (verify-later! thunk)
+  (*verify-later!* thunk))
+
+(define (set-verify-later! proc)
+  (set! *verify-later!* proc))
+
+(define (note-name! thing name)
+  (cond ((interface? thing)
+	 (note-interface-name! thing name))
+	((structure? thing)
+	 (note-structure-name! thing name)))
+  thing)
diff --git a/scheme/bcomp/ddata.scm b/scheme/bcomp/ddata.scm
new file mode 100644
index 0000000..4fab4d6
--- /dev/null
+++ b/scheme/bcomp/ddata.scm
@@ -0,0 +1,36 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Stuff moved from segment.scm  6/5/93
+; Some of that stuff moved to state.scm 4/28/95
+
+; Debug-data records are for communicating information from the
+; compiler to various debugging tools.
+
+; An environment map has the form
+;   #(pc-before pc-after #(name ...) (env-map ...))
+; where the two pc's delimit the region of code that executes in this
+; environment.  The names indicate which variables become bound at
+; pc-before, and the list of env-maps is for inferior (deeper)
+; environments.
+
+; pc-in-parent gives the pc of a make-closure instruction in the code
+; for this template's superior (outer) lambda-expression.
+
+; Source is in the form of an a-list mapping pc's used in continuations
+; to pairs of the form (i . expression), indicating that the continuation
+; is returning the value of i'th subexpression in the source expression.
+
+(define-record-type debug-data :debug-data
+  (make-debug-data uid name parent pc-in-parent env-maps source)
+  debug-data?
+  (uid      debug-data-uid)
+  (name	    debug-data-name)
+  (parent   debug-data-parent)
+  (pc-in-parent debug-data-pc-in-parent)
+  (env-maps debug-data-env-maps set-debug-data-env-maps!)
+  (source   debug-data-source set-debug-data-source!))
+
+(define-record-discloser :debug-data
+  (lambda (dd)
+    (list 'debug-data (debug-data-uid dd) (debug-data-name dd))))
diff --git a/scheme/bcomp/for-reify.scm b/scheme/bcomp/for-reify.scm
new file mode 100644
index 0000000..5e8fe96
--- /dev/null
+++ b/scheme/bcomp/for-reify.scm
@@ -0,0 +1,55 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Things used by the expression returned by REIFY-STRUCTURES.
+; Cf. link/reify.scm.
+
+(define (operator name type-exp)
+  (get-operator name (sexp->type type-exp #t)))
+
+(define (primop name)
+  (get-primop name))
+
+(define (simple-interface names types)
+  (make-simple-interface #f
+			 (map (lambda (name type)
+				(list name (sexp->type type #t)))
+			      (vector->list names)
+			      (vector->list types))))
+
+(define (package names locs get-location uid)
+  (let ((end (vector-length names))
+	(p (make-package list list ;(lambda () '())
+			 #f #f "" '()
+			 uid #f)))
+    (set-package-loaded?! p #t)
+    (do ((i 0 (+ i 1)))
+	((= i end))
+      (let* ((name (vector-ref names i))
+	     (probe (package-lookup p name)))
+	(if (not (binding? probe))
+	    (package-define! p
+			     name
+			     usual-variable-type
+			     (get-location (vector-ref locs i))
+			     #f))))
+    (make-table-immutable! (package-definitions p))
+    p))
+
+(define (transform names+proc env type-exp source name)
+  (make-transform names+proc env (sexp->type type-exp #t) source name))
+
+(define (package-define-static! package name static)
+  (package-define! package
+		   name
+		   (cond ((transform? static)
+			  (transform-type static))
+			 ((primop? static)
+			  (primop-type static))
+			 ((operator? static)
+			  (operator-type static))
+			 ((structure? static)
+			  structure-type)
+			 (else
+			  (error "unknown kind of static value" static)))
+		   #f
+		   static))
diff --git a/scheme/bcomp/interface.scm b/scheme/bcomp/interface.scm
new file mode 100644
index 0000000..4df7f04
--- /dev/null
+++ b/scheme/bcomp/interface.scm
@@ -0,0 +1,87 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Interfaces
+
+(define-record-type interface :interface
+  (really-make-interface ref walk clients name)
+  interface?
+  (ref ref-method)
+  (walk walk-method)
+  (clients interface-clients)
+  (name interface-name set-interface-name!))
+
+(define-record-discloser :interface
+  (lambda (int) (list 'interface (interface-name int))))
+
+(define (interface-ref int name)
+  ((ref-method int) name))
+
+(define (for-each-declaration proc int)
+  ((walk-method int) proc))
+
+(define (note-reference-to-interface! int thing)
+  (let ((pop (interface-clients int)))
+    (if pop
+	(add-to-population! thing pop)
+	;; If it's compound, we really ought to descend into its components
+	)))
+
+; If name is #f, then the interface is anonymous, so we don't need to
+; make a population.
+
+(define (make-interface ref walk name)
+  (really-make-interface ref
+			 walk
+			 (make-population)
+			 name))
+
+; Simple interfaces (export (name type) ...)
+
+(define (make-simple-interface name items)
+  (let ((table (make-symbol-table)))
+    (for-each (lambda (item)
+		(if (pair? item)
+		    (let ((name (car item))
+			  (type (cadr item)))
+		      (if (or (null? name) (pair? name))
+			  ;; Allow ((name1 name2 ...) type)
+			  (for-each (lambda (name)
+				      (table-set! table name type))
+				    name)
+			  (table-set! table name type)))
+		    (table-set! table item undeclared-type)))
+	      items)
+    (make-table-immutable! table)
+    (really-make-simple-interface table name)))
+
+(define (really-make-simple-interface table name)
+  (make-interface (lambda (name) (table-ref table name))
+		  (lambda (proc) (table-walk proc table))
+		  name))
+
+
+; Compoune interfaces
+
+(define (make-compound-interface name . ints)
+  (let ((int
+	 (make-interface (lambda (name)
+			   (let loop ((ints ints))
+			     (if (null? ints)
+				 #f
+				 (or (interface-ref (car ints) name)
+				     (loop (cdr ints))))))
+			 (lambda (proc)
+			   (for-each (lambda (int)
+				       (for-each-declaration proc int))
+				     ints))
+			 name)))
+    (for-each (lambda (i)
+		(note-reference-to-interface! i int))
+	      ints)
+    int))
+
+
+(define (note-interface-name! int name)
+  (if (and name (not (interface-name int)))
+      (set-interface-name! int name)))
diff --git a/scheme/bcomp/module-language.scm b/scheme/bcomp/module-language.scm
new file mode 100644
index 0000000..3197d42
--- /dev/null
+++ b/scheme/bcomp/module-language.scm
@@ -0,0 +1,220 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; The DEFINE-INTERFACE and DEFINE-STRUCTURE macros.
+
+(define-syntax def
+  (syntax-rules ()
+    ((def (?name . ?args) ?body ...)
+     (really-def () ?name (lambda ?args ?body ...)))
+    ((def ?name ...)
+     (really-def () ?name ...))))
+
+(define-syntax really-def
+  (syntax-rules ()
+    ((really-def (?name ...) ?exp)
+     (define-multiple (?name ...)
+       (begin (verify-later! (lambda () ?name))
+	      ...
+	      ?exp)))
+    ((really-def (?name ...) ?name1 ?etc ...)
+     (really-def (?name ... ?name1) ?etc ...))))
+
+(define-syntax define-multiple
+  (syntax-rules ()
+    ((define-multiple (?name) ?exp)
+     (define ?name (note-name! ?exp '?name)))
+    ((define-multiple (?name ...) ?exp)
+     (begin (define ?name #f)
+	    ...
+	    (let ((frob (lambda things
+			  (begin (set! ?name
+				       (note-name! (car things) '?name))
+				 (set! things (cdr things)))
+			  ...)))
+	      (call-with-values (lambda () ?exp) frob))))))
+
+
+; Interfaces
+
+; <definition> ::= (define-interface <name> <int>)
+; <int> ::= <name> | (export <item> ...) | (compound-interface <int> ...)
+
+(define-syntax define-interface
+  (syntax-rules ()
+    ((define-interface ?name ?int)
+     (def ?name ?int))))
+
+(define-syntax compound-interface
+  (syntax-rules ()
+    ((compound-interface ?int ...)
+     (make-compound-interface #f ?int ...))))
+
+
+; <item> ::= <name> | (<name> <type>) | ((<name> ...) <type>)
+
+(define-syntax export
+  (lambda (e r c)
+    (let ((items (cdr e)))
+      (let loop ((items items)
+		 (plain '())
+		 (others '()))
+	(if (null? items)
+	    `(,(r 'make-simple-interface)
+	      #f
+	      (,(r 'list) (,(r 'quote) ,(list (reverse plain)
+					      ':undeclared))
+			  ,@(reverse others)))
+	    (let ((item (car items)))
+	      (if (pair? item)
+		  (loop (cdr items)
+			plain
+			(cons `(,(r 'list) (,(r 'quote) ,(car item))
+					   ,(cadr item))
+			      others))
+		  (loop (cdr items)
+			(cons item plain)
+			others)))))))
+  (make-simple-interface list quote value))
+
+		    
+; Structures
+
+(define-syntax define-structure
+  (syntax-rules ()
+    ((define-structure ?name ?int ?clause1 ?clause ...)
+     (def ?name (structure ?int ?clause1 ?clause ...)))
+    ;; For compatibility.  Use DEF instead.
+    ((define-structure ?name ?exp)
+     (def ?name ?exp))))
+
+(define-syntax define-structures
+  (syntax-rules ()
+    ((define-structures ((?name ?int) ...)
+       ?clause ...)
+     (def ?name ... (structures (?int ...) ?clause ...)))))
+
+(define-syntax structure
+  (syntax-rules ()
+    ((structure ?int ?clause ...)
+     (structures (?int) ?clause ...))))
+
+(define-syntax structures
+  (syntax-rules ()
+    ((structures (?int ...) ?clause ...)
+     (let ((p (a-package #f ?clause ...)))
+       (values (make-structure p (lambda () ?int))
+	       ...)))))
+; Packages
+
+(define-syntax a-package
+  (let ()
+
+    (define (parse-package-clauses clauses rename compare)
+      (let ((%open (rename 'open))
+	    (%access (rename 'access))
+	    (%for-syntax (rename 'for-syntax)))
+	(let loop ((clauses clauses)
+		   (opens '())
+		   (accesses '())
+		   (for-syntaxes '())
+		   (others '()))
+	  (cond ((null? clauses)
+		 (values opens accesses for-syntaxes (reverse others)))
+		((not (list? (car clauses)))
+		 (display "Ignoring invalid define-structures clause")
+		 (newline)
+		 (write (car clauses)) (newline)
+		 (loop (cdr clauses)
+		       opens
+		       accesses
+		       for-syntaxes
+		       others))
+		(else
+		 (let ((keyword (caar clauses)))
+		   (cond ((compare keyword %open)
+			  (loop (cdr clauses)
+				(append opens (cdar clauses))
+				accesses
+				for-syntaxes
+				others))
+			 ((compare keyword %access)
+			  (loop (cdr clauses)
+				opens
+				(append (cdar clauses) accesses)
+				for-syntaxes
+				others))
+			 ((compare keyword %for-syntax)
+			  (loop (cdr clauses)
+				opens
+				accesses
+				(append (cdar clauses) for-syntaxes)
+				others))
+			 (else
+			  (loop (cdr clauses)
+				opens
+				accesses
+				for-syntaxes
+				(cons (car clauses) others))))))))))
+
+    (lambda (form rename compare)
+      (let ((names (cadr form))
+	    (clauses (cddr form)))
+	(call-with-values (lambda ()
+			    (parse-package-clauses clauses rename compare))
+	  (lambda (opens accesses for-syntaxes others)
+	    (let ((%make (rename 'make-a-package))
+		  (%lambda (rename 'lambda))
+		  (%cons (rename 'cons))
+		  (%list (rename 'list))
+		  (%quote (rename 'quote))
+		  (%a-package (rename 'a-package))
+		  (%file-name (rename '%file-name%)))
+	      `(,%make (,%lambda () (,%list ,@opens))
+		       (,%lambda ()
+			   (,%list ,@(map (lambda (a)
+					    `(,%cons (,%quote ,a) ,a))
+					  accesses)))
+		       (,(string->symbol ".make-reflective-tower.")
+			(,%quote ,for-syntaxes)
+			(,%quote ,names))		; for discloser
+		       (,%file-name)
+		       (,%quote ,others)
+		       (,%quote ,names))))))))
+  (cons lambda list make-a-package quote make-reflective-tower %file-name%))
+
+(define-syntax receive
+  (syntax-rules ()
+    ((receive (?var ...) ?producer . ?body)
+     (call-with-values (lambda () ?producer)
+       (lambda (?var ...)
+	 (note-name! ?var '?var) ...
+	 (let () . ?body))))))
+
+
+; (DEFINE-REFLECTIVE-TOWER-MAKER <proc>)
+;   <proc> should be an expression that evaluates to a procedure of
+;   two arguments.  The first argument is a list of DEFINE-STRUCTURE
+;   clauses, and the second is some identifying information (no
+;   semantic content).  The procedure should return a "reflective
+;   tower", which is a pair (<eval-proc> . <env>).  To evaluate the
+;   right-hand side of a DEFINE-SYNTAX (LET-SYNTAX, etc.) form,
+;   <eval-proc> is called on the right-hand side and <env>.
+; Got that?
+
+(define-syntax define-reflective-tower-maker
+  (lambda (e r c)
+    `(,(r 'define) ,(string->symbol ".make-reflective-tower.") ,(cadr e)))
+  (define))
+
+(define-syntax export-reflective-tower-maker
+  (lambda (e r c)
+    `(,(r 'export) ,(string->symbol ".make-reflective-tower.")))
+  (export))
+
+; Modules  = package combinators...
+
+(define-syntax define-module
+  (syntax-rules ()
+    ((define-module (?name . ?args) ?body ...)
+     (def ?name (lambda ?args ?body ...)))))
diff --git a/scheme/bcomp/mtype.scm b/scheme/bcomp/mtype.scm
new file mode 100644
index 0000000..2354cf6
--- /dev/null
+++ b/scheme/bcomp/mtype.scm
@@ -0,0 +1,823 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Type lattice.
+; Sorry this is so hairy, but before it was written, type checking 
+; consumed 15% of compile time.
+
+(define-record-type meta-type :meta-type
+  (really-make-type mask more info)
+  meta-type?
+  (mask type-mask)
+  (more type-more)
+  (info type-info))
+
+; MASK is a bit set.  The current bits are:
+;
+; Non values:
+;   syntax
+;   other static type
+;   no values - indicates an optional type; the type with only this bit set
+;     is the empty rail type.
+;   two or more - indicates a rail-type with at least two elements
+;     
+; Values:
+;   exact integer
+;   integer
+;   exact rational
+;   rational
+;   exact real
+;   real
+;   exact complex
+;   complex
+;   other exact number
+;   other number
+;   boolean
+;   pair
+;   null
+;   record
+;   procedure
+;   other
+;
+; The MORE field is only used for rail types, which are like ML's tuples.
+; If the TWO-OR-MORE? bit is set, then 
+;  more = (head . tail).
+; Otherwise, more = #f.
+;
+; For procedure types, the PROCEDURE bit is set and the INFO field is a three
+; element list: (domain codomain restrictive?)
+;  If INFO field for the type of F is (t1 t2 #t), then
+;    if x : t1 then (f x) : t2 (possible error!), else (f x) : error.
+;  If INFO field for the type of F is (t1 t2 #f), then
+;    there exists an x : t1 such that (f x) : t2.
+;
+; For types which do not have bits, the OTHER bit is set and the INFO field is
+; a symbol naming some type that doesn't have its own bit in the mask.  The
+; other types defined in this file are:
+;
+;   :char
+;   :unspecific
+;   :string
+;   :symbol
+;   :vector
+;   :escape
+;   :structure
+;
+; More are constructed later by using SEXP->TYPE.
+
+(define-record-discloser :meta-type
+  (lambda (t)
+    `(type ,(let ((m (type-mask t)))
+	      (or (table-ref mask->name-table m)
+		  m))
+	   ,(let ((more (type-more t)))
+	      (if (and (pair? more) (eq? (cdr more) t))
+		  '*
+		  more))
+	   ,(type-info t))))
+
+(define (make-type mask more info)
+  (make-immutable!
+   (really-make-type mask more info)))
+
+(define name->type-table (make-table))
+(define mask->name-table (make-table))
+
+(define (name->type x)
+  (or (table-ref name->type-table x)
+      (make-other-type x)))
+
+(define (set-type-name! type name)
+  (table-set! name->type-table name type)
+  (if (not (or (type-info type)
+	       (type-more type)))
+      (table-set! mask->name-table (type-mask type) name)))
+	     
+; Masks
+; Top of lattice has mask = -1, bottom has mask = 0.
+
+(define *mask* 1)
+
+(define (new-type-bit)
+  (let ((m *mask*))
+    (set! *mask* (arithmetic-shift *mask* 1))
+    m))
+
+(define (mask->type mask)
+  (make-type mask #f #f))
+
+(define bottom-type (mask->type 0))
+(define error-type bottom-type)
+
+(define (bottom-type? t)
+  (= (type-mask t) 0))
+
+(set-type-name! bottom-type ':error)
+
+(define (new-atomic-type)
+  (mask->type (new-type-bit)))
+
+(define (named-atomic-type name)
+  (let ((t (new-atomic-type)))
+    (set-type-name! t name)
+    t))
+
+; --------------------
+; Top of the lattice.
+
+(define syntax-type (named-atomic-type ':syntax))
+(define other-static-type (new-atomic-type))
+
+; --------------------
+
+; "Rails" are argument sequence or return value sequences.
+; Four constructors:
+;   empty-rail-type
+;   (rail-type t1 t2)
+;   (optional-rail-type t1 t2)
+;   (make-rest-type t)
+
+; If a type's two-or-more? bit is set, then
+;  more = (head . tail).
+; Otherwise, more = #f.
+
+(define empty-rail-type (new-atomic-type))
+
+(define (rail-type t1 t2)		;CONS analog
+  (cond ((empty-rail-type? t2) t1)
+	((bottom-type? t1) t1)
+	((bottom-type? t2) t2)
+	((and (optional-type? t1)
+	      (rest-type? t2)
+	      (same-type? t1 (head-type t2)))
+	 ;; Turn (&opt t &rest t) into (&rest t)
+	 t2)
+	((or (optional-type? t1)
+	     (optional-type? t2))
+	 (make-type (bitwise-ior (type-mask t1) mask/two-or-more)
+		    (make-immutable! (cons t1 t2))
+		    #f))
+	(else
+	 (make-type mask/two-or-more
+		    (make-immutable! (cons t1 t2))
+		    (type-info t1)))))
+
+(define (make-optional-type t)
+  (if (type-more t)
+      (warn "peculiar type in make-optional-type" t))
+  (make-type (bitwise-ior (type-mask t) mask/no-values)
+	     #f
+	     (type-info t)))
+
+; A rest type is an infinite rail type with both the no-values and the
+; two-or-more bits set.
+
+(define (make-rest-type t)
+  (if (bottom-type? t)
+      t
+      (let* ((z (cons (make-optional-type t) #f))
+	     (t (make-type (bitwise-ior (type-mask t) mask/&rest)
+			   z
+			   (type-info t))))
+	(set-cdr! z t)
+	(make-immutable! z)
+	t)))
+
+(define (head-type t)			;Can return an &opt type
+  (let ((more (type-more t)))
+    (if more
+	(car more)
+	t)))
+
+(define (head-type-really t)		;Always returns a value type
+  (let ((h (head-type t)))
+    (if (optional-type? h)
+	(make-type (bitwise-and (type-mask h) (bitwise-not mask/no-values))
+		   #f
+		   (type-info h))
+	h)))
+	  
+(define (tail-type t)
+  (if (empty-rail-type? t)
+      ;; bottom-type   ?
+      (warn "rail-type of empty rail" t))
+  (let ((more (type-more t)))
+    (if more
+	(cdr more)
+	empty-rail-type)))
+
+(define (empty-rail-type? t)
+  (= (bitwise-and (type-mask t) mask/one-or-more) 0))
+
+(define (rest-type? t)			;For terminating recursions
+  (let ((more (type-more t)))
+    (and more
+	 (eq? (cdr more) t))))
+
+(define (optional-type? t)
+  (> (bitwise-and (type-mask t) mask/no-values) 0))
+
+
+; The no-values type has one element, the rail of length zero.
+; The two-or-more type consists of all rails of length two
+; or more.
+
+(define mask/no-values (type-mask empty-rail-type))
+(define mask/two-or-more (new-type-bit))
+(define mask/&rest (bitwise-ior (type-mask empty-rail-type)
+				mask/two-or-more))
+
+(table-set! mask->name-table mask/no-values ':no-values)
+
+(define value-type (mask->type (bitwise-not (- *mask* 1))))
+(set-type-name! value-type ':value)
+(define mask/value (type-mask value-type))
+
+(define (value-type? t)
+  (let ((m (type-mask t)))
+    (= (bitwise-and m mask/value) m)))
+
+(define any-values-type
+  (make-rest-type value-type))
+(set-type-name! any-values-type ':values)
+				   
+(define any-arguments-type any-values-type)
+
+(define mask/one-or-more
+  (bitwise-ior mask/value mask/two-or-more))
+
+; --------------------
+; Lattice operations.
+
+; Equivalence
+
+(define (same-type? t1 t2)
+  (or (eq? t1 t2)
+      (and (= (type-mask t1) (type-mask t2))
+	   (let ((more1 (type-more t1))
+		 (more2 (type-more t2)))
+	     (if more1
+		 (and more2
+		      (if (eq? (cdr more1) t1)
+			  (eq? (cdr more2) t2)
+			  (if (eq? (cdr more2) t2)
+			      #f
+			      (and (same-type? (car more1) (car more2))
+				   (same-type? (cdr more1) (cdr more2))))))
+		 (not more2)))
+	   (let ((info1 (type-info t1))
+		 (info2 (type-info t2)))
+	     (or (eq? info1 info2)		; takes care of OTHER types
+		 (and (pair? info1)		; check for same procedure types
+		      (pair? info2)
+		      (same-type? (car info1) (car info2))
+		      (same-type? (cadr info1) (cadr info2))
+		      (eq? (caddr info1) (caddr info2))))))))
+
+(define (subtype? t1 t2)		;*** optimize later
+  (same-type? t1 (meet-type t1 t2)))
+
+; (mask->type mask/procedure) represents the TOP of the procedure
+; subhierarchy.
+
+(define (meet-type t1 t2)
+  (if (same-type? t1 t2)
+      t1
+      (let ((m (bitwise-and (type-mask t1) (type-mask t2))))
+	(cond ((> (bitwise-and m mask/two-or-more) 0)
+	       (meet-rail t1 t2))
+	      ((eq? (type-info t1) (type-info t2))
+	       (make-type m #f (type-info t1)))
+	      ((> (bitwise-and m mask/other) 0)
+	       (let ((i1 (other-type-info t1))
+		     (i2 (other-type-info t2)))
+		 (if (and i1 i2)
+		     (mask->type (bitwise-and m (bitwise-not mask/other)))
+		     (make-type m
+				#f
+				(or i1 i2)))))
+	      ((> (bitwise-and m mask/procedure) 0)
+	       (meet-procedure m t1 t2))
+	      (else
+	       (mask->type m))))))
+
+(define (other-type-info t)
+  (let ((i (type-info t)))
+    (if (pair? i) #f i)))
+
+;(define (p name x) (write `(,name ,x)) (newline) x)
+
+(define (meet-rail t1 t2)
+  (let ((t (meet-type (head-type t1)
+		      (head-type t2))))
+    (if (and (rest-type? t1)
+	     (rest-type? t2))
+	(make-rest-type t)
+	(rail-type t (meet-type (tail-type t1)
+				(tail-type t2))))))
+	       
+; Start with these assumptions:
+;
+;  . (meet? t1 t2) == (not (bottom-type? (meet-type t1 t2)))
+;  . (subtype? t1 t2) == (same-type? t1 (meet-type t1 t2))
+;  . (subtype? t1 t2) == (same-type? t2 (join-type t1 t2))
+;  . We signal a type error if not (intersect? have want).
+;  . We infer the type of a parameter by intersecting the want-types
+;    of all definitely-reached points of use.
+;
+; 1. If both types are nonrestrictive, we have to JOIN both domains
+; and codomains (if we are to avoid conjunctive types).
+;
+; (+ (f 1) (car (f 'a)))    [reconstructing type of f by computing meet of all contexts]
+;   => meet (proc (:integer) :number nonr) (proc (:symbol) :pair nonr)
+;   => (proc ((join :integer :symbol) (join :number :pair)) nonr), yes?
+;
+; 2. If both types are restrictive, we need to MEET both domains and
+; codomains.
+;
+; (define (foo) 3),   (export (foo (proc (:value) :value)))
+;  Error - disjoint domains.
+;
+; (define (foo) 'baz),   (export (foo (proc () :number)))
+;  Error - disjoint codomains.
+;
+; 3. If one is restrictive and the other isn't then we still need to
+; MEET on both sides.
+;
+; (with-output-to-file "foo" car)
+;   => meet (proc () :any nonr), (proc (:pair) :value restr)
+;   => Error - disjoint domains.
+;
+; (frob (lambda () 'a))  where (define (frob f) (+ (f) 1))
+;   => meet (proc () :symbol restr), (proc () :number nonr)
+;   => Error - disjoint codomains.
+;
+; Does export checking look for (intersect? want have), or for
+; (subtype? want have) ?  We should be able to narrow something as we
+; export it, but not widen it.
+;
+; (define (foo . x) 3),   (export (foo (proc (value) value)))
+;  No problem, since the domain of the first contains the domain of the second.
+;
+; (define (foo x . y) (+ x 3)),   (export (foo (proc (value) value)))
+;  Dubious; the domains intersect but are incomparable.  The meet
+;  should be (proc (number) number).
+;
+; (define (foo x) (numerator x)),   (export (foo (proc (real) integer)))
+;  This is dubious, since the stated domain certainly contains values
+;  that will be rejected.  (But then, what about divide by zero, or
+;  vector indexing?)
+;
+; (define (foo x) (numerator x)),   (export (foo (proc (integer) integer)))
+;  This should definitely be OK.
+
+(define (meet-procedure m t1 t2)
+  (let ((dom1 (procedure-type-domain t1))
+	(dom2 (procedure-type-domain t2))
+	(cod1 (procedure-type-codomain t1))
+	(cod2 (procedure-type-codomain t2)))
+    (cond ((or (restrictive? t1)
+	       (restrictive? t2))
+	   (let ((dom (meet-type dom1 dom2))
+		 (cod (meet-type cod1 cod2)))
+	     (if (or (bottom-type? dom)
+		     (and (bottom-type? cod)
+			  (not (bottom-type? cod1)) ;uck
+			  (not (bottom-type? cod2))))
+		 (mask->type (bitwise-and m (bitwise-not mask/procedure)))
+		 (make-procedure-type m
+				      dom
+				      cod
+				      #t))))
+	  ((and (subtype? dom2 dom1)
+		(subtype? cod2 cod1))
+	   ;; exists x : dom1 s.t. (f x) : cod1   adds no info
+	   (make-procedure-type m dom2 cod2 #f))
+	  (else
+	   ;; Arbitrary choice.
+	   (make-procedure-type m dom1 cod1 #f)))))
+
+; MEET? is the operation used all the time by the compiler.  We want
+; getting a yes answer to be as fast as possible.  We could do
+;
+;   (define (meet? t1 t2) (not (bottom-type? (meet-type t1 t2))))
+;
+; but that would be too slow.
+
+(define (meet? t1 t2)
+  (or (eq? t1 t2)
+      (let ((m (bitwise-and (type-mask t1)
+			    (type-mask t2))))
+	(cond ((= m mask/two-or-more)
+	       (and (meet? (head-type t1)
+			   (head-type t2))
+		    (meet? (tail-type t1)
+			   (tail-type t2))))
+	      ((= m 0)
+	       #f)
+	      ((eq? (type-info t1)
+		    (type-info t2))
+	       #t)
+	      ((= m mask/other)
+	       (not (and (other-type-info t1)
+			 (other-type-info t2))))
+	      ((= m mask/procedure)
+	       (meet-procedure? t1 t2))
+	      (else
+	       #t)))))
+
+(define (meet-procedure? t1 t2)
+  (if (or (restrictive? t1)
+	  (restrictive? t2))
+      (and (meet? (procedure-type-domain t1)
+		  (procedure-type-domain t2))
+	   (meet? (procedure-type-codomain t1)
+		  (procedure-type-codomain t2)))
+      #t))
+
+
+; Join
+
+(define (join-type t1 t2)
+  (if (same-type? t1 t2)
+      t1
+      (let ((m (bitwise-ior (type-mask t1)
+			    (type-mask t2))))
+	(if (> (bitwise-and m mask/two-or-more) 0)
+	    (join-rail t1 t2)
+	    (let ((info1 (type-info t1))
+		  (info2 (type-info t2)))
+	      (cond ((equal? info1 info2)
+		     (make-type m #f (type-info t1)))
+		    ((> (bitwise-and m mask/other) 0)
+		     (make-type m #f #f))
+		    ((> (bitwise-and m mask/procedure) 0)
+		     (join-procedure m t1 t2))
+		    (else
+		     (error "This shouldn't happen" t1 t2))))))))
+
+(define (join-rail t1 t2)
+  (let ((t (join-type (head-type t1) (head-type t2))))
+    (if (and (rest-type? t1)
+	     (rest-type? t2))
+	(make-rest-type t)
+	(rail-type t
+		   (if (type-more t1)
+		       (if (type-more t2)
+			   (join-type (tail-type t1)
+				      (tail-type t2))
+			   (tail-type t1))
+		       (tail-type t2))))))
+	
+; This is pretty gross.
+
+(define (join-procedure m t1 t2)
+  (if (procedure-type? t1)
+      (if (procedure-type? t2)
+	  (let ((dom1 (procedure-type-domain t1))
+		(dom2 (procedure-type-domain t2))
+		(cod1 (procedure-type-codomain t1))
+		(cod2 (procedure-type-codomain t2)))
+	    (make-procedure-type m
+				 (join-type dom1 dom2) ;Error when outside here
+				 (join-type cod1 cod2)
+				 (and (restrictive? t1)
+				      (restrictive? t2))))
+	  (make-type m #f (type-info t1)))
+      (make-type m #f (type-info t2))))
+
+
+; --------------------
+; Value types.
+
+; First, the ten indivisible number types.
+
+(define number-hierarchy
+  '(:integer :rational :real :complex :number))
+
+(let loop ((names number-hierarchy)
+	   (exact bottom-type)
+	   (inexact bottom-type))
+  (if (null? names)
+      (begin (set-type-name! exact ':exact)
+	     (set-type-name! inexact ':inexact))
+      (let* ((exact (join-type exact (new-atomic-type)))
+	     (inexact (join-type inexact (new-atomic-type))))
+	(set-type-name! (join-type exact inexact)
+			(car names))
+	(loop (cdr names)
+	      exact
+	      inexact))))
+
+(define integer-type  (name->type ':integer))
+(define rational-type (name->type ':rational))
+(define real-type     (name->type ':real))
+(define complex-type  (name->type ':complex))
+(define number-type   (name->type ':number))
+(define exact-type    (name->type ':exact))
+(define inexact-type  (name->type ':inexact))
+
+(define exact-integer-type (meet-type integer-type exact-type))
+(set-type-name! exact-integer-type ':exact-integer)
+
+(define inexact-real-type (meet-type real-type exact-type))
+(set-type-name! inexact-real-type ':inexact-real)
+
+; Next, all the others.
+
+(define boolean-type (named-atomic-type ':boolean))
+(define pair-type (named-atomic-type ':pair))
+(define null-type (named-atomic-type ':null))
+(define record-type (named-atomic-type ':record))
+
+(define any-procedure-type (named-atomic-type ':procedure))
+
+; ???
+; (define procedure-nonbottom-type (new-atomic-type))
+; (define procedure-bottom-type (new-atomic-type))
+; (define mask/procedure (meet procedure-nonbottom-type procedure-bottom-type))
+
+; OTHER-VALUE-TYPE is a catchall for all the other ones we don't
+; anticipate (for now including string, vector, char, etc.).
+
+(define other-value-type (named-atomic-type ':other))
+(define mask/other (type-mask other-value-type))
+
+(define (make-other-type id)
+  (let ((t (make-type mask/other #f id)))
+    (set-type-name! t id)
+    t))
+
+(define char-type	(make-other-type ':char))
+(define unspecific-type (make-other-type ':unspecific))
+(define string-type	(make-other-type ':string))
+(define symbol-type	(make-other-type ':symbol))
+(define vector-type	(make-other-type ':vector))
+(define escape-type	(make-other-type ':escape))
+(define structure-type  (make-other-type ':structure))
+
+
+; --------------------
+; Procedures.
+
+(define mask/procedure (type-mask any-procedure-type))
+
+(define (procedure-type dom cod r?)
+  (make-procedure-type mask/procedure dom cod r?))
+
+(define (make-procedure-type m dom cod r?)
+  (make-type m
+	     #f
+	     (if (and (not r?)
+		      (same-type? dom value-type)
+		      (same-type? cod value-type))
+		 #f	;LUB of all procedure types
+		 (list dom cod r?))))
+
+(define (procedure-type-domain t)
+  (let ((info (type-info t)))
+    (if (pair? info)
+	(car info)
+	any-values-type)))
+
+(define (procedure-type-codomain t)
+  (let ((info (type-info t)))
+    (if (pair? info)
+	(cadr info)
+	any-values-type)))
+
+(define (restrictive? t)
+  (let ((info (type-info t)))
+    (if (pair? info)
+	(caddr info)
+	#f)))
+
+; --------------------
+; Conversion to and from S-expression.
+
+(define (sexp->type x r?)
+  (cond ((symbol? x)
+	 (name->type x))
+	((pair? x)
+	 (case (car x)
+	   ((some-values)
+	    (sexp->values-type (cdr x) #t r?))
+	   ((proc procedure-type)
+	    (let ((r? (if (or (null? (cdddr x))
+			      (eq? (cadddr x) r?))
+			  r?
+			  (not r?))))
+	      (procedure-type (sexp->values-type (cadr x) #t (not r?))
+			      (sexp->type (caddr x) r?)
+			      r?)))
+	   ((meet)
+	    (if (null? (cdr x))
+		bottom-type
+		(let ((l (map (lambda (x) (sexp->type x r?)) (cdr x))))
+		  (reduce meet-type (car l) (cdr l)))))
+	   ((join)
+	    (let ((l (map (lambda (x) (sexp->type x r?)) (cdr x))))
+	      (reduce join-type (car l) (cdr l))))
+	   ((mask->type)
+	    (mask->type (cadr x)))
+	   (else (error "unrecognized type" x))))
+	(else (error "unrecognized type" x))))
+
+(define (sexp->values-type l req? r?)
+  (cond ((null? l)
+	 empty-rail-type)
+	((eq? (car l) '&rest)
+	 (make-rest-type (sexp->type (cadr l) r?)))
+	((eq? (car l) '&opt)
+	 (sexp->values-type (cdr l) #f r?))
+ 	((eq? (car l) 'rail-type)
+ 	 (sexp->values-type (cdr l) req? r?))
+	(else
+	 (let ((t (sexp->type (car l) r?)))
+	   (rail-type (if req? t (make-optional-type t))
+		      (sexp->values-type (cdr l)
+					 req?
+					 r?))))))
+
+; Convert type to S-expression
+
+(define (type->sexp t r?)
+  (if (> (bitwise-and (type-mask t) mask/&rest) 0)
+      (if (same-type? t any-values-type)
+	  ':values
+	  `(some-values ,@(rail-type->sexp t r?)))
+      (let ((j (disjoin-type t)))
+	(cond ((null? j) ':error)
+	      ((null? (cdr j))
+	       (atomic-type->sexp (car j) r?))
+	      (else
+	       `(join ,@(map (lambda (t)
+			       (atomic-type->sexp t r?))
+			     j)))))))
+	 
+(define (atomic-type->sexp t r?)
+  (let ((m (type-mask t)))
+    (cond ((and (not (type-info t))
+		(table-ref mask->name-table m)))
+	  ((= m mask/other) 
+	   (or (type-info t) ':value))	;not quite
+	  ((= m mask/procedure)
+	   (let ((r (restrictive? t)))
+	     `(proc ,(rail-type->sexp (procedure-type-domain t)
+				      (not r))
+		    ,(type->sexp (procedure-type-codomain t) r)
+		    ,@(if (eq? r r?)
+			  '()
+			  `(,r)))))
+	  ((type-info t)
+	   `(ill-formed ,(type-mask t) ,(type-info t)))
+	  ((subtype? t exact-type)
+	   `(meet :exact
+		  ,(type->sexp (mask->type (let ((m (type-mask t)))
+					     (bitwise-ior m (arithmetic-shift m 1))))
+			       #t)))
+	  ((subtype? t inexact-type)
+	   `(meet :inexact
+		  ,(type->sexp (mask->type (let ((m (type-mask t)))
+					     (bitwise-ior m (arithmetic-shift m -1))))
+			       #t)))
+	  ;; ((meet? t number-type) ...)
+	  (else
+	   `(mask->type ,(type-mask t))))))
+
+(define (rail-type->sexp t r?)
+  (let recur ((t t) (prev-req? #t) (r? r?))
+    (cond ((empty-rail-type? t) '())
+	  ((rest-type? t)
+	   `(&rest ,(type->sexp (head-type-really t) r?)))
+	  ((optional-type? t)
+	   (let ((tail (cons (type->sexp (head-type-really t) r?)
+			     (recur (tail-type t) #f r?))))
+	     (if prev-req?
+		 `(&opt ,@tail)
+		 tail)))
+	  (else
+	   (cons (type->sexp (head-type t) r?)
+		 (recur (tail-type t) #t r?))))))
+
+; Decompose a type into components
+
+(define (disjoin-type t)
+  (cond ((bottom-type? t) '())
+	((and (not (type-info t))
+	      (table-ref mask->name-table (type-mask t)))
+	 (list t))
+	((meet? t other-value-type)
+	 (cons (meet-type t other-value-type)
+	       (disjoin-rest t mask/other)))
+	((meet? t any-procedure-type)
+	 (cons (meet-type t any-procedure-type)
+	       (disjoin-rest t mask/procedure)))
+	((meet? t number-type)
+	 (cons (meet-type t number-type)
+	       (disjoin-rest t mask/number)))
+	(else
+	 (do ((i 1 (arithmetic-shift i 1)))
+	     ((> (bitwise-and (type-mask t) i) 0)
+	      (cons (mask->type i)
+		    (disjoin-rest t i)))))))
+
+(define (disjoin-rest t mask)
+  (disjoin-type (mask->type (bitwise-and (type-mask t)
+					 (bitwise-not mask)))))
+
+(define mask/number (type-mask number-type))
+
+; --------------------
+; obsolescent?  see lambda and values reconstructors in recon.scm
+
+(define (make-some-values-type types)
+  (if (null? types)
+      empty-rail-type
+      (rail-type (car types) (make-some-values-type (cdr types)))))
+
+(define-syntax proc
+  (syntax-rules ()
+    ((proc (?type ...) ?cod)
+     (procedure-type (some-values ?type ...) ?cod #t))
+    ((proc (?type ...) ?cod ?r)
+     (procedure-type (some-values ?type ...) ?cod ?r))))
+
+(define-syntax some-values
+  (syntax-rules (&opt &rest)
+    ((some-values) empty-rail-type)
+    ((some-values &opt) empty-rail-type)
+    ((some-values ?t) ?t)
+    ((some-values &rest ?t) (make-rest-type ?t))
+    ((some-values &opt &rest ?t) (make-rest-type ?t))
+    ((some-values &opt ?t1 . ?ts)
+     (rail-type (make-optional-type ?t1)
+                (some-values &opt . ?ts)))
+    ((some-values ?t1 . ?ts)
+     (rail-type ?t1 (some-values . ?ts)))))
+
+(define (procedure-type? t)
+  (= (type-mask t) mask/procedure))
+
+(define (fixed-arity-procedure-type? t)
+  (and (procedure-type? t)
+       (let loop ((d (procedure-type-domain t)))
+	 (cond ((empty-rail-type? d) #t)
+	       ((optional-type? d) #f)
+	       (else (loop (tail-type d)))))))
+
+(define (procedure-type-arity t)
+  (do ((d (procedure-type-domain t) (tail-type d))
+       (i 0 (+ i 1)))
+      ((empty-rail-type? d) i)
+    (if (optional-type? d)
+	(error "this shouldn't happen" t d))))
+
+(define (procedure-type-argument-types t)
+  (let recur ((d (procedure-type-domain t)))
+    (cond ((empty-rail-type? d) '())
+	  ((optional-type? d)
+	   (call-error "lossage" procedure-type-argument-types t))
+	  (else
+	   (cons (head-type d)
+		 (recur (tail-type d)))))))
+
+;----------------
+; Odd types - variable types and the undeclared type
+;
+; These were elsewhere (syntax.scm) and should be here.  If I could understand
+; the above code I could make these be `real' types.
+
+(define (variable-type type)
+  (list 'variable type))
+
+(define (variable-type? type)
+  (and (pair? type) (eq? (car type) 'variable)))
+
+(define variable-value-type cadr)
+
+; Usual type for Scheme variables.
+
+(define usual-variable-type (variable-type value-type))
+
+; cf. EXPORT macro
+
+(define undeclared-type ':undeclared)
+
+;----------------
+; Used in two places:
+; 1. GET-LOCATION checks to see if the context of use (either variable
+;    reference or assignment) is compatible with the declared type.
+; 2. CHECK-STRUCTURE checks to see if the reconstructed type is compatible
+;    with any type declared in the interface.
+
+(define (compatible-types? have-type want-type)
+  (if (variable-type? want-type)
+      (and (variable-type? have-type)
+	   (same-type? (variable-value-type have-type)
+		       (variable-value-type want-type)))
+      (meet? (if (variable-type? have-type)
+		 (variable-value-type have-type)
+		 have-type)
+	     want-type)))
+
+
diff --git a/scheme/bcomp/name.scm b/scheme/bcomp/name.scm
new file mode 100644
index 0000000..dcf792c
--- /dev/null
+++ b/scheme/bcomp/name.scm
@@ -0,0 +1,165 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Names (symbols) and generated names.
+
+(define (name? thing)
+  (or (symbol? thing)
+      (generated? thing)))
+
+; Generated names
+
+; Generated names make lexically-scoped macros work.  They're the same
+; as what Alan Bawden and Chris Hanson call "aliases".  The parent
+; field is always another name (perhaps generated).  The parent chain
+; provides an access path to the name's binding, should one ever be
+; needed.  That is: If name M is bound to a transform T that generates
+; name G as an alias for name N, then M is (generated-parent-name G),
+; so we can get the binding of G by accessing the binding of N in T's
+; environment of closure, and we get T by looking up M in the
+; environment in which M is *used*.
+
+(define-record-type generated :generated
+  (make-generated symbol token env parent-name)
+  generated?
+  (symbol      generated-symbol)
+  (token       generated-token)
+  (env	       generated-env)
+  (parent-name generated-parent-name))
+
+(define-record-discloser :generated
+  (lambda (name)
+    (list 'generated (generated-symbol name) (generated-uid name))))
+
+(define (generate-name symbol env parent-name)    ;for opt/inline.scm
+  (make-generated symbol (cons #f #f) env parent-name)) ;foo
+
+(define (generated-uid generated-name)
+  (let ((token (generated-token generated-name)))
+    (or (car token)
+	(let ((uid *generated-uid*))
+	  (set! *generated-uid* (+ *generated-uid* 1))
+	  (set-car! token uid)
+	  uid))))
+
+(define *generated-uid* 0)
+
+(define (name->symbol name)
+  (if (symbol? name)
+      name
+      (string->symbol (string-append (symbol->string (generated-symbol name))
+				     "##"
+				     (number->string (generated-uid name))))))
+
+(define (name-hash name)
+  (cond ((symbol? name)
+	 (string-hash (symbol->string name)))
+	((generated? name)
+	 (name-hash (generated-symbol name)))
+	(else
+	 (error "invalid name" name))))
+
+(define make-name-table (make-table-maker eq? name-hash))
+
+; Used by QUOTE to turn generated names back into symbols
+
+(define (desyntaxify thing)
+  (cond ((or (boolean? thing) (null? thing) (number? thing)
+	     (symbol? thing) (char? thing))
+	 thing)
+	((string? thing)
+	 (make-immutable! thing))
+	((generated? thing)
+	 (desyntaxify (generated-symbol thing)))
+	((pair? thing)
+	 (make-immutable!
+	  (let ((x (desyntaxify (car thing)))
+		(y (desyntaxify (cdr thing))))
+	    (if (and (eq? x (car thing))
+		     (eq? y (cdr thing)))
+		thing
+		(cons x y)))))
+	((vector? thing)
+	 (make-immutable!
+	  (let ((new (make-vector (vector-length thing) #f)))
+	    (let loop ((i 0) (same? #t))
+	      (if (>= i (vector-length thing))
+		  (if same? thing new)
+		  (let ((x (desyntaxify (vector-ref thing i))))
+		    (vector-set! new i x)
+		    (loop (+ i 1)
+			  (and same? (eq? x (vector-ref thing i))))))))))
+	(else
+	 (warn "invalid datum in quotation" thing)
+	 thing)))
+
+;----------------
+; Qualified names
+; 
+; A qualified name is a generated name that has been translated into a path.
+; For example, if syntax A introduces a reference to procedure B, then the
+; reference to B, as a qualified name, will be #(>> A B).  If B has refers
+; C and is substituted in-line, then the reference to C is #(>> #(>> A B) C).
+; The binding for C can be located by going to the structure which supplies A,
+; finding where it gets B from, and then looking up C there.
+
+; These can't be records because they are included in linked images.
+
+(define (make-qualified transform-name sym uid)
+  (vector '>> transform-name sym uid))
+
+(define (qualified? thing)
+  (and (vector? thing)
+       (= (vector-length thing) 4)
+       (eq? (vector-ref thing 0) '>>)))
+
+(define (qualified-parent-name q) (vector-ref q 1))
+(define (qualified-symbol q) (vector-ref q 2))
+
+; Convert an alias (generated name) to S-expression form ("qualified name").
+
+(define (name->qualified name env)
+  (cond ((not (generated? name))
+	 name)
+	((let ((d0 (lookup env name))
+	       (d1 (lookup env (generated-symbol name))))
+	   (and d0 d1 (same-denotation? d0 d1)))
+	 (generated-symbol name))   ;+++
+	(else
+	 (make-qualified (qualify-parent (generated-parent-name name)
+					 env)
+			 (generated-symbol name)
+			 (generated-uid name)))))
+	 
+; As an optimization, we elide intermediate steps in the lookup path
+; when possible.  E.g.
+;     #(>> #(>> #(>> define-record-type define-accessors)
+;		define-accessor)
+;	   record-ref)
+; is replaced with
+;     #(>> define-record-type record-ref)
+
+(define (qualify-parent name env)
+  (let recur ((name name))
+    (if (generated? name)
+	(let ((parent (generated-parent-name name)))
+	  (if (let ((b1 (lookup env name))
+		    (b2 (lookup env parent)))
+		(and b1
+		     b2
+		     (or (same-denotation? b1 b2)
+			 (and (binding? b1)
+			      (binding? b2)
+			      (let ((s1 (binding-static b1))
+				    (s2 (binding-static b2)))
+				(and (transform? s1)
+				     (transform? s2)
+				     (eq? (transform-env s1)
+					  (transform-env s2))))))))
+	      (recur parent) ;+++
+	      (make-qualified (recur parent)
+			      (generated-symbol name)
+			      (generated-uid name))))
+	name)))
+  
+
+
diff --git a/scheme/bcomp/node.scm b/scheme/bcomp/node.scm
new file mode 100644
index 0000000..b65e69f
--- /dev/null
+++ b/scheme/bcomp/node.scm
@@ -0,0 +1,143 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; --------------------
+; Operators (= special operators and primitives)
+
+(define-record-type operator :operator
+  (make-operator type nargs uid name)
+  operator?
+  (type operator-type set-operator-type!)
+  (nargs operator-nargs)
+  (uid operator-uid)
+  (name operator-name))
+
+(define-record-discloser :operator
+  (lambda (s)
+    (list 'operator
+	  (operator-name s)
+	  (if (symbol? (operator-type s))
+	      (operator-type s)
+	      (type->sexp (operator-type s) #t)))))
+
+(define usual-operator-type
+  (procedure-type any-arguments-type value-type #f))
+
+(define (get-operator name . type-option)
+  (let ((type (if (null? type-option) #f (car type-option)))
+	(probe (table-ref operators-table name)))
+    (if (operator? probe)
+	(let ((previous-type (operator-type probe)))
+	  (cond ((not type))
+		((not previous-type)
+		 (set-operator-type! probe type))
+		((symbol? type)		; 'leaf or 'internal
+		 (if (not (eq? type previous-type))
+		     (warn "operator type inconsistency" name type previous-type)))
+		((subtype? type previous-type)  ;Improvement
+		 (set-operator-type! probe type))
+		((not (subtype? previous-type type))
+		 (warn "operator type inconsistency"
+		       name
+		       (type->sexp previous-type 'foo)
+		       (type->sexp type 'foo))))
+	  probe)
+	(let* ((uid *operator-uid*)
+	       (op (make-operator type
+				  (if (and type
+					   (not (symbol? type))
+					   (fixed-arity-procedure-type? type))
+				      (procedure-type-arity type)
+				      #f)
+				  uid
+				  name)))
+	  (if (>= uid number-of-operators)
+	      (warn "too many operators" (operator-name op) (operator-type op)))
+	  (set! *operator-uid* (+ *operator-uid* 1))
+	  (table-set! operators-table (operator-name op) op)
+	  (vector-set! the-operators uid op)
+	  op))))
+
+(define *operator-uid* 0)
+
+(define operators-table (make-table))
+
+(define number-of-operators 400)  ;Fixed-size limits bad, but speed good
+(define the-operators (make-vector number-of-operators #f))
+
+; --------------------
+; Operator tables (for fast dispatch)
+
+(define (make-operator-table default)
+  (make-vector number-of-operators default))
+
+(define operator-table-ref vector-ref)
+
+(define (operator-lookup table op)
+  (operator-table-ref table (operator-uid op)))
+
+(define (operator-define! table name type proc)
+  (vector-set! table
+	       (operator-uid (get-operator name type))
+	       proc))
+
+; --------------------
+; Nodes
+
+; A node is an annotated expression (or definition or other form).
+; The FORM component of a node is an S-expression of the same form as
+; the S-expression representation of the expression.  E.g. for
+; literals, the form is the literal value; for variables the form is
+; the variable name; for IF expressions the form is a 4-element list
+; (ignored test con alt).  Nodes also have a tag identifying what kind
+; of node it is (literal, variable, if, etc.) and a property list.
+
+(define-record-type node :node
+  (really-make-node uid form plist)
+  node?
+  (uid node-operator-id)
+  (form node-form)
+  (plist node-plist set-node-plist!))
+
+(define-record-discloser :node
+  (lambda (n) (list (operator-name (node-operator n)) (node-form n))))
+
+(define (make-node operator form)
+  (really-make-node (operator-uid operator) form '()))
+
+(define (node-ref node key)
+  (let ((probe (assq key (node-plist node))))
+    (if probe (cdr probe) #f)))
+
+(define (node-set! node key value) ;gross
+  (if value
+      (let ((probe (assq key (node-plist node))))
+	(if probe
+	    (set-cdr! probe value)
+	    (set-node-plist! node (cons (cons key value) (node-plist node)))))
+      (let loop ((l (node-plist node)) (prev #f))
+	(cond ((null? l) 'lose)
+	      ((eq? key (caar l))
+	       (if prev
+		   (set-cdr! prev (cdr l))
+		   (set-node-plist! node (cdr l))))
+	      (else (loop (cdr l) l))))))
+
+(define (node-operator node)
+  (vector-ref the-operators (node-operator-id node)))
+
+(define (node-predicate name . type-option)
+  (let ((id (operator-uid (apply get-operator name type-option))))
+    (lambda (node)
+      (= (node-operator-id node) id))))
+
+(define (make-similar-node node form)
+  (if (equal? form (node-form node))
+      node
+      (make-node (node-operator node) form)))
+
+; Top-level nodes are often delayed.
+
+(define (force-node node)
+  (if (node? node)
+      node
+      (force node)))
diff --git a/scheme/bcomp/optimize.scm b/scheme/bcomp/optimize.scm
new file mode 100644
index 0000000..66d2f77
--- /dev/null
+++ b/scheme/bcomp/optimize.scm
@@ -0,0 +1,28 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Optimizers
+
+(define optimizers-table (make-table))
+
+(define (set-optimizer! name opt)
+  (table-set! optimizers-table name opt))
+
+(define (get-optimizer names)
+  (lambda (forms package)
+    (apply-optimizers (map (lambda (name)
+			     (or (table-ref optimizers-table name)
+				 (begin
+				   (signal 'note
+					   "optional optimization pass not invoked"
+					   name)
+				   (lambda (forms package) forms))))
+			   names)
+		      forms
+		      package)))
+
+(define (apply-optimizers optimizers forms package)
+  (fold (lambda (optimizer forms)
+	  (optimizer forms package))
+	optimizers
+	forms))
+
diff --git a/scheme/bcomp/package-undef.scm b/scheme/bcomp/package-undef.scm
new file mode 100644
index 0000000..cabd472
--- /dev/null
+++ b/scheme/bcomp/package-undef.scm
@@ -0,0 +1,207 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; The entry point for all this.
+
+(define (link! template package noise?)
+  (if noise?
+      (noting-undefined-variables package
+				  (lambda ()
+				    (really-link! template package)))
+      (really-link! template package)))
+
+(define (really-link! template package)  
+  (do ((i 0 (+ i 1)))
+      ((= i (template-length template)))
+    (let ((x (template-ref template i)))
+      (cond ((thingie? x)
+	     (template-set! template
+			    i
+			    (get-location (thingie-binding x)
+					  package
+					  (thingie-name x)
+					  (thingie-want-type x))))
+	    ((template? x)
+	     (really-link! x package))))))
+
+; GET-LOCATION returns a location to be stored away in a template.  If the
+; wanted meta-type, which is either `value-type' or `usual-variable-type'
+; (for SET!), matches that in the binding, then we just return the binding's
+; location after noting that we are doing so.
+;
+; If the type doesn't match then we make a location and remember that we
+; have done so.  If correct location becomes available later we will replace
+; the bogus one (see env/pedit.scm).
+
+(define (get-location binding cenv name want-type)
+  (if (binding? binding)
+      (let ((place (binding-place binding)))
+	(cond ((compatible-types? (binding-type binding) want-type)
+	       (note-caching! cenv name place)
+	       place)
+	      ((variable-type? want-type)
+	       (get-location-for-unassignable cenv name))
+	      (else
+	       (warn "invalid variable reference" name)
+	       (note-caching! cenv name place)
+	       place)))
+      (get-location-for-undefined cenv name)))
+
+; Packages have three tables used by env/pedit.scm:
+;   undefineds
+;     locations introduced for missing values
+;   undefined-but-assigneds
+;     locations introduced for missing cells
+;   cached
+;     locations used here that were supposed to have been provided by
+;     someone else
+
+; Get a location from PACKAGE's table at ACCESSOR.
+
+(define (location-on-demand accessor)
+  (lambda (package name)
+    (let ((table (accessor package)))
+      (or (table-ref table name)
+	  (let ((new (make-new-location package name)))
+	    (table-set! table name new)
+	    new)))))
+
+(define get-undefined
+  (location-on-demand package-undefineds))
+
+(define location-for-assignment
+  (location-on-demand package-undefined-but-assigneds))
+
+; If this package is mutable and it gets NAME from some other structure
+; then add NAME and PLACE to its table of cached locations.
+
+(define (package-note-caching! package name place)
+  (if (package-unstable? package)
+      (if (not (table-ref (package-definitions package) name))
+	  (let loop ((opens (package-opens package)))
+	    (if (not (null? opens))
+		(if (interface-ref (structure-interface (car opens))
+				   name)
+		    (begin (table-set! (package-cached package) name place)
+			   (package-note-caching!
+			       (structure-package (car opens))
+			       name place))
+		    (loop (cdr opens))))))))
+
+; Find the actual package providing PLACE and remember that it is being used.
+
+(define (note-caching! cenv name place)
+  (if (generated? name)
+      (note-caching! (generated-env name)
+		     (generated-symbol name)
+		     place)
+      (let ((package (cenv->package cenv)))
+        (if (package? package)
+            (package-note-caching! package name place)))))
+
+; Get a location for NAME which is SET! but isn't supposed to be.
+
+(define (get-location-for-unassignable cenv name)
+  (if (generated? name)
+      (get-location-for-unassignable (generated-env name)
+				     (generated-symbol name))
+      (let ((package (cenv->package cenv)))
+	(warn "invalid assignment" name)
+	(if (package? package)
+	    (lambda () (location-for-assignment package name))
+	    (lambda () (make-undefined-location name))))))
+
+; Get a location for NAME, which is undefined.
+
+(define (get-location-for-undefined cenv name)
+  (if (generated? name)
+      (get-location-for-undefined (generated-env name)
+				  (generated-symbol name))
+      (let ((package (cenv->package cenv)))
+	((or (fluid $note-undefined)
+	     (lambda (cenv name) (values)))
+	   cenv
+	   name)
+        (if (package? package)
+	    (let ((place (location-for-reference package name)))
+	      (package-note-caching! package name place)
+	      place)
+	    (make-undefined-location name)))))
+	    
+(define $note-undefined (make-fluid (lambda (cenv name) (values))))
+
+; Because of generated names CENV may not be an actual compile-env
+; (i.e. a procedure).
+
+(define (cenv->package cenv)
+  (cond ((procedure? cenv)
+         ;; This returns #f if package is stable (static linking).
+         (extract-package-from-environment cenv))
+        ((package? cenv)
+	 cenv)
+        ((structure? cenv)
+	 (structure-package cenv))))
+
+; Exported for env/pedit.scm.
+
+(define (location-for-reference package name)
+  (let loop ((opens (package-opens package)))
+    (if (null? opens)
+	(get-undefined package name)
+	(if (interface-ref (structure-interface (car opens))
+			   name)
+	    (location-for-reference (structure-package (car opens)) name)
+	    (loop (cdr opens))))))
+
+;----------------
+; Maintain and display a list of undefined names.
+; We bind $NOTE-UNDEFINED to a procedure that adds names to LOSERS, an a-list of
+; (<package> . <undefined-names>).  Once THUNK has finished we print out any
+; names that are still undefined.  CURRENT-PACKAGE is used only to avoid printing
+; out the name of the current package unnecessarily.  CURRENT-PACKAGE may be #f.
+
+(define (noting-undefined-variables current-package thunk)
+  (let* ((losers '())
+	 (add-name (lambda (env name)
+		     (let ((probe (assq env losers)))
+		       (if probe
+			   (if (not (member name (cdr probe)))
+			       (set-cdr! probe (cons name (cdr probe))))
+			   (set! losers (cons (list env name) losers)))))))
+    (let-fluid $note-undefined
+        (lambda (env name)
+	  (if (generated? name)
+	      (add-name (generated-env name)
+			(generated-symbol name))
+	      (add-name env name)))
+      (lambda ()
+	(dynamic-wind
+	 (lambda () #f)
+	 thunk
+	 (lambda ()
+	   (for-each (lambda (env+names)
+		       (print-undefined-names (car env+names)
+					      (cdr env+names)
+					      current-package))
+		     losers)))))))
+
+(define (print-undefined-names env names current-package)
+  (let ((names (filter (lambda (name)
+			 ;; Keep the ones that are still unbound.
+			 (not (generic-lookup env name)))
+		       names)))
+    (if (not (null? names))
+	(let ((out (current-noise-port)))
+	  (newline out)
+	  (display "Undefined" out)
+	  (if (and current-package
+		   (not (eq? env current-package)))
+	      (begin (display " in " out)
+		     (write env out)))
+	  (display ": " out)
+	  (write (map (lambda (name)
+			(if (generated? name)
+			    (generated-symbol name)
+			    name))
+		      (reverse names))
+		 out)
+	  (newline out)))))
diff --git a/scheme/bcomp/package.scm b/scheme/bcomp/package.scm
new file mode 100644
index 0000000..c49aa0d
--- /dev/null
+++ b/scheme/bcomp/package.scm
@@ -0,0 +1,418 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Structures 'n' packages.
+
+; --------------------
+; Structures
+;
+; A structure is a map from names to binding records, determined by an
+; interface (a set of names) and a package (a map from names to binding
+; records).
+;
+; The interface is specified as a thunk.  This removes dependencies on the
+; order in which structures are defined.  Also, if the interface is redefined,
+; re-evaluating the thunk produces the new, correct interface (see
+; env/pedit.scm).
+;
+; Clients are packages that import the structure's bindings.
+
+(define-record-type structure :structure
+  (really-make-structure package interface-thunk interface clients name)
+  structure?
+  (interface-thunk structure-interface-thunk)
+  (interface structure-interface-really set-structure-interface!)
+  (package   structure-package)
+  (clients   structure-clients)
+  (name	     structure-name set-structure-name!))
+
+(define-record-discloser :structure
+  (lambda (structure)
+    (list 'structure
+	  (package-uid (structure-package structure))
+	  (structure-name structure))))
+
+; Get the actual interface, calling the thunk if necessary.
+
+(define (structure-interface structure)
+  (or (structure-interface-really structure)
+      (begin (initialize-structure! structure)
+	     (structure-interface-really structure))))
+
+(define (initialize-structure! structure)
+  (let ((int ((structure-interface-thunk structure))))
+    (if (interface? int)
+	(begin (set-structure-interface! structure int)
+	       (note-reference-to-interface! int structure))
+	(call-error "invalid interface" initialize-structure! structure))))
+
+; Make a structure over PACKAGE and the interface returned by INT-THUNK.
+
+(define (make-structure package int-thunk . name-option)
+  (if (not (package? package))
+      (call-error "invalid package" make-structure package int-thunk))
+  (let ((struct (really-make-structure package
+				       (if (procedure? int-thunk)
+					   int-thunk
+					   (lambda () int-thunk))
+				       #f
+				       (make-population)
+				       #f)))
+    (if (not (null? name-option))
+	(note-structure-name! struct (car name-option)))
+    (add-to-population! struct (package-clients package))
+    struct))
+
+; STRUCT has name NAME.  NAME can then also be used to refer to STRUCT's
+; package.
+
+(define (note-structure-name! struct name)
+  (if (and name (not (structure-name struct)))
+      (begin (set-structure-name! struct name)
+	     (note-package-name! (structure-package struct) name))))
+
+; A structure is unstable if it's package is.  An unstable package is one
+; where new code may be added, possibly modifying the exported bindings.
+
+(define (structure-unstable? struct)
+  (package-unstable? (structure-package struct)))
+
+; Map PROC down the the [name type binding] triples provided by STRUCT.
+
+(define (for-each-export proc struct)
+  (let ((int (structure-interface struct)))
+    (for-each-declaration
+        (lambda (name want-type)
+	  (let ((binding (real-structure-lookup struct name want-type #t)))
+	    (proc name
+		  (if (and (binding? binding)
+			   (eq? want-type undeclared-type))
+		      (let ((type (binding-type binding)))
+			(if (variable-type? type)
+			    (variable-value-type type)
+			    type))
+		      want-type)
+		  binding)))
+	int)))
+
+; --------------------
+; Packages
+
+(define-record-type package :package
+  (really-make-package uid
+		       opens-thunk opens accesses-thunk
+		       definitions
+		       undefineds
+		       undefined-but-assigneds
+		       get-location
+		       cached
+		       clients
+		       unstable?
+		       integrate?
+		       file-name clauses loaded?)
+  package?
+  (uid	           package-uid)
+  (opens           package-opens-really set-package-opens!)
+  (definitions     package-definitions)
+  (unstable?       package-unstable?)
+  (integrate?      package-integrate? set-package-integrate?!)
+
+  ;; For EVAL and LOAD (which can only be done in unstable packages)
+  (get-location    package-get-location set-package-get-location!)
+  (file-name       package-file-name)
+  (clauses         package-clauses)
+  (loaded?         package-loaded? set-package-loaded?!)
+  (env             package->environment set-package->environment!)
+
+  ;; For package mutation
+  (opens-thunk     package-opens-thunk set-package-opens-thunk!)
+  (accesses-thunk  package-accesses-thunk)
+  (undefineds      package-real-undefineds set-package-undefineds!)
+  (undefined-but-assigneds
+                   package-real-undefined-but-assigneds
+		   set-package-undefined-but-assigneds!)
+  (clients         package-clients)
+  (cached	   package-cached))
+
+(define-record-discloser :package
+  (lambda (package)
+    (let ((name (package-name package)))
+      (if name
+	  (list 'package (package-uid package) name)
+	  (list 'package (package-uid package))))))
+
+(define (make-package opens-thunk accesses-thunk unstable? tower file clauses
+		      uid name)
+  (let ((new (really-make-package
+	       (if uid
+		   (begin (if (>= uid *package-uid*)
+			      (set! *package-uid* (+ uid 1)))
+			  uid)
+		   (new-package-uid))
+	       opens-thunk
+	       #f			;opens
+	       accesses-thunk		;thunk returning alist
+	       (make-name-table)	;definitions
+	       #f			;undefineds
+	       #f			;undefined-but-assigned
+	       (fluid $get-location)	;procedure for making new locations
+	       (make-name-table)	;bindings cached in templates
+	       (make-population)	;structures
+	       unstable?		;unstable (suitable for EVAL)?
+	       #t			;integrate?
+	       file			;file containing DEFINE-STRUCTURE form
+	       clauses			;misc. DEFINE-STRUCTURE clauses
+	       #f)))			;loaded?
+    (note-package-name! new name)
+    (set-package->environment! new (really-package->environment new tower))
+    new))
+
+; TOWER is a promise that is expected to deliver, when forced, a
+; pair (eval . env).
+
+(define (really-package->environment package tower)
+  (make-compiler-env (lambda (name)
+		       (package-lookup package name))
+		     (lambda (name type . maybe-static)
+		       (package-define! package
+					name
+					type
+					#f
+					(if (null? maybe-static)
+					    #f
+					    (car maybe-static))))
+		     tower
+		     package))	; interim hack
+
+; Two tables that we add lazily.
+
+(define (lazy-table-accessor slot-ref slot-set!)
+  (lambda (package)
+    (or (slot-ref package)
+	(let ((table (make-name-table)))
+	  (slot-set! package table)
+	  table))))
+
+(define package-undefineds
+  (lazy-table-accessor package-real-undefineds
+		       set-package-undefineds!))
+
+(define package-undefined-but-assigneds
+  (lazy-table-accessor package-real-undefined-but-assigneds
+		       set-package-undefined-but-assigneds!))
+
+; Unique id's
+
+(define (new-package-uid)
+  (let ((uid *package-uid*))		;unique identifier
+    (set! *package-uid* (+ *package-uid* 1))
+    uid))
+
+(define *package-uid* 0)
+
+; Package names
+
+(define package-name-table (make-table))
+
+(define (package-name package)
+  (table-ref package-name-table (package-uid package)))
+
+(define (note-package-name! package name)
+  (if name
+      (let ((uid (package-uid package)))
+	(if (not (table-ref package-name-table uid))
+	    (table-set! package-name-table uid name)))))
+
+(define (package-opens package)
+  (initialize-package-if-necessary! package)
+  (package-opens-really package))
+
+(define (initialize-package-if-necessary! package)
+  (if (not (package-opens-really package))
+      (initialize-package! package)))
+
+(define (package-accesses package)		;=> alist
+  ((package-accesses-thunk package)))
+
+; --------------------
+; A simple package has no ACCESSes or other far-out clauses.
+
+(define (make-simple-package opens unstable? tower . name-option)
+  (if (not (list? opens))
+      (error "invalid package opens list" opens))
+  (let ((package (make-package (lambda () opens)
+			       (lambda () '()) ;accesses-thunk
+			       unstable?
+			       tower
+			       ""	;file containing DEFINE-STRUCTURE form
+			       '()	;clauses
+			       #f	;uid
+			       (if (null? name-option)
+				   #f
+				   (car name-option)))))
+    (set-package-loaded?! package #t)
+    package))
+
+; --------------------
+; The definitions table
+
+; Each entry in the package-definitions table is a binding
+; #(type place static).
+
+(define (package-definition package name)
+  (initialize-package-if-necessary! package)
+  (let ((probe (table-ref (package-definitions package) name)))
+    (if probe
+	(maybe-fix-place! probe)
+	#f)))
+
+(define (package-define! package name type place static)
+  (let ((probe (table-ref (package-definitions package) name)))
+    (if probe
+	(begin
+	  (clobber-binding! probe type place static)
+	  (binding-place (maybe-fix-place! probe)))
+	(let ((place (or place (get-new-location package name))))
+	  (table-set! (package-definitions package)
+		      name
+		      (make-binding type place static))
+	  place))))
+
+(define (package-add-static! package name static)
+  (let ((probe (table-ref (package-definitions package) name)))
+    (if probe
+	(clobber-binding! probe
+			  (binding-type probe)
+			  (binding-place probe)
+			  static)
+	(error "internal error: name not bound" package name))))
+
+(define (package-refine-type! package name type)
+  (let ((probe (table-ref (package-definitions package) name)))
+    (if probe
+	(clobber-binding! probe
+			  type
+			  (binding-place probe)
+			  (binding-static probe))
+	(error "internal error: name not bound" package name))))
+
+; --------------------
+; Lookup
+
+; Look up a name in a package.  Returns a binding if bound, or a name if
+; not.  In the unbound case we return #f.
+
+(define (package-lookup package name)
+  (really-package-lookup package name (package-integrate? package)))
+
+(define (really-package-lookup package name integrate?)
+  (let ((probe (package-definition package name)))
+    (cond (probe
+	   (if integrate?
+	       probe
+	       (forget-integration probe)))
+	  ((generated? name)
+	   ; Access path is (generated-parent-name name)
+	   (generic-lookup (generated-env name)
+			   (generated-symbol name)))
+	  (else
+	   (search-opens (package-opens-really package) name integrate?)))))
+
+; Look for NAME in structures OPENS.
+
+(define (search-opens opens name integrate?)
+  (let loop ((opens opens))
+    (if (null? opens)
+	#f
+	(or (structure-lookup (car opens) name integrate?)
+	    (loop (cdr opens))))))
+
+(define (structure-lookup struct name integrate?)
+  (let ((type (interface-ref (structure-interface struct) name)))
+    (if type
+	(real-structure-lookup struct name type integrate?)
+	#f)))
+
+(define (real-structure-lookup struct name type integrate?)
+  (impose-type type
+	       (really-package-lookup (structure-package struct)
+				      name
+				      integrate?)
+	       integrate?))
+
+(define (generic-lookup env name)
+  (cond ((package? env)
+	 (package-lookup env name))
+	((structure? env)
+	 (or (structure-lookup env
+			       name
+			       (package-integrate? (structure-package env)))
+	     (call-error "not exported" generic-lookup env name)))
+	;((procedure? env)
+	; (lookup env name))
+	(else
+	 (error "invalid environment" env name))))
+
+; --------------------
+; Package initialization
+
+(define (initialize-package! package)
+  (let ((opens ((package-opens-thunk package))))
+    (set-package-opens! package opens)
+    (for-each (lambda (struct)
+		(if (structure-unstable? struct)
+		    (add-to-population! package (structure-clients struct))))
+	      opens))
+  (for-each (lambda (name+struct)
+	      ;; Cf. CLASSIFY method for STRUCTURE-REF
+	      (package-define! package 
+			       (car name+struct)
+			       structure-type
+			       #f
+			       (cdr name+struct)))
+	    (package-accesses package)))
+
+; (define (package->environment? env)
+;   (eq? env (package->environment
+;	        (extract-package-from-environment env))))
+
+
+; --------------------
+; For implementation of INTEGRATE-ALL-PRIMITIVES! in scanner, etc.
+
+(define (for-each-definition proc package)
+  (table-walk (lambda (name binding)
+		(proc name (maybe-fix-place! binding)))
+	      (package-definitions package)))
+
+; --------------------
+; Locations
+
+(define (get-new-location package name)
+  ((package-get-location package) package name))
+
+; Default new-location method for new packages
+
+(define (make-new-location package name)
+  (let ((uid *location-uid*))
+    (set! *location-uid* (+ *location-uid* 1))
+    (table-set! location-info-table uid
+		(make-immutable!
+		 (cons (name->symbol name) (package-uid package))))
+    (make-undefined-location uid)))
+
+(define $get-location (make-fluid make-new-location))
+
+(define *location-uid* 5000)  ; 1510 in initial system as of 1/22/94
+
+(define location-info-table (make-table))
+
+
+(define (flush-location-names)
+  (set! location-info-table (make-table))
+  ;; (set! package-name-table (make-table)) ;hmm, not much of a space saver
+  )
+
+; (put 'package-define! 'scheme-indent-hook 2)
+
+
diff --git a/scheme/bcomp/primop.scm b/scheme/bcomp/primop.scm
new file mode 100644
index 0000000..6557490
--- /dev/null
+++ b/scheme/bcomp/primop.scm
@@ -0,0 +1,33 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Primops.
+
+(define-record-type primop :primop
+  (make-primop name type closed compilator)
+  primop?
+  (name primop-name)
+  (type primop-type)
+  (closed primop-closed)
+  (compilator primop-compilator))
+
+(define-record-discloser :primop
+  (lambda (primop)
+    `(primop ,(primop-name primop))))
+
+(define primop-table (make-symbol-table))
+
+; This is used to add definitions of the primitives to a package.
+
+(define (walk-primops proc)
+  (table-walk (lambda (name primop)
+		(proc name (primop-type primop) primop))
+	      primop-table))
+
+(define (define-compiler-primitive name type compilator closed)
+  (table-set! primop-table
+	      name
+	      (make-primop name (or type value-type) closed compilator)))
+
+(define (get-primop name)
+  (or (table-ref primop-table name)
+      (error "unknown compiler primitive" name)))
diff --git a/scheme/bcomp/read-form.scm b/scheme/bcomp/read-form.scm
new file mode 100644
index 0000000..2964aaa
--- /dev/null
+++ b/scheme/bcomp/read-form.scm
@@ -0,0 +1,31 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; The value of $NOTE-FILE-PACKAGE is called whenever a file is loaded into
+; a package.  env/debug.scm uses this to associate packages with files so
+; that code stuffed to the REPL will be eval'ed in the correct package.
+;
+; Is there any point in having this be a fluid?
+
+(define $note-file-package
+  (make-fluid (lambda (filename package)
+		(values))))
+
+(define (read-forms pathname package)
+  (let* ((filename (namestring pathname #f *scheme-file-type*))
+	 (truename (translate filename)))
+    (call-with-input-file truename
+      (lambda (port)
+	((fluid $note-file-package) filename package)
+	(let ((o-port (current-noise-port)))
+	  (display truename o-port)
+	  (force-output o-port)
+	  (really-read-forms port))))))
+
+(define (really-read-forms port)	    
+  (let loop ((forms '()))
+    (let ((form (read port)))
+      (if (eof-object? form)
+	  (reverse forms)
+	  (loop (cons form forms))))))
+
+
diff --git a/scheme/bcomp/recon.scm b/scheme/bcomp/recon.scm
new file mode 100644
index 0000000..b962513
--- /dev/null
+++ b/scheme/bcomp/recon.scm
@@ -0,0 +1,323 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Rudimentary type reconstruction, hardly worthy of the name.
+
+; Currently, NODE-TYPE is called in two places.  One is to determine
+; the type of the right-hand side of a DEFINE for a variable that is
+; never assigned, so uses of the variable can be checked later.  The
+; other is when compiling a call, to check types of arguments and
+; produce warning messages.
+
+; This is heuristic, to say the least.  It's not clear what the right
+; interface or formalism is for Scheme; I'm still experimenting.
+
+; Obviously we can't do Hindley-Milner inference.  Not only does
+; Scheme have subtyping, but it also has dependent types up the wazoo.
+; For example, the following is perfectly correct Scheme:
+;
+;   (define (foo x y) (if (even? x) (car y) (vector-ref y 3)))
+
+(define (node-type node)
+  (reconstruct node 'fast any-values-type))
+
+(define (reconstruct-type node env)
+  (reconstruct node '() any-values-type))
+
+(define (reconstruct node constrained want-type)
+  ((operator-table-ref reconstructors (node-operator-id node))
+    node
+    constrained
+    want-type))
+
+(define (examine node constrained want-type)
+  (if (pair? constrained)
+      (reconstruct node constrained want-type)
+      want-type))
+
+(define reconstructors
+  (make-operator-table (lambda (node constrained want-type)
+                         (reconstruct-call (node-form node)
+					   constrained
+					   want-type))))
+
+(define (define-reconstructor name type proc)
+  (operator-define! reconstructors name type proc))
+
+(define-reconstructor 'lambda syntax-type
+  (lambda (node constrained want-type)
+    (reconstruct-lambda node constrained want-type #f)))
+
+(define-reconstructor 'flat-lambda syntax-type
+  (lambda (node constrained want-type)
+    (reconstruct-lambda node constrained want-type #f)))
+
+(define (reconstruct-lambda node constrained want-type called?)
+  (if (eq? constrained 'fast)
+      any-procedure-type
+      (let* ((form (node-form node))
+	     (want-result (careful-codomain want-type))
+	     (formals (cadr form))
+	     (alist (map (lambda (node)
+			   (cons node value-type))
+			 (normalize-formals formals)))
+	     (cod (reconstruct (last form)	; works for normal and flat
+			       (if called?
+				   (append alist constrained)
+				   alist)
+			       want-result)))
+	(procedure-type (if (n-ary? formals)
+			    any-values-type ;lose
+			    (make-some-values-type (map cdr alist)))
+			cod
+			#t))))
+
+(define (careful-codomain proc-type)
+  (if (procedure-type? proc-type)
+      (procedure-type-codomain proc-type)
+      any-values-type))
+
+(define-reconstructor 'name 'leaf
+  (lambda (node constrained want-type)
+    (if (eq? constrained 'fast)
+        (reconstruct-name node)
+        (let ((z (assq node constrained)))
+          (if z
+              (let ((type (meet-type (cdr z) want-type)))
+                (begin (set-cdr! z type)
+                       type))
+              (reconstruct-name node))))))
+
+(define (reconstruct-name node)
+  (let ((probe (node-ref node 'binding)))
+    (if (binding? probe)
+        (let ((type (binding-type probe)))
+          (cond ((variable-type? type)
+		 (variable-value-type type))
+                ((subtype? type value-type)
+		 type)
+                (else
+		 value-type)))
+        value-type)))
+
+(define-reconstructor 'call 'internal
+  (lambda (node constrained want-type)
+    (let ((form (node-form node)))
+      (cond ((proc->reconstructor (car form))
+	     => (lambda (recon)
+		  (recon (cdr form) constrained want-type)))
+	    (else
+	     (reconstruct-call form constrained want-type))))))
+
+; See if PROC is a primop or a variable bound to a primop, and then return
+; that primops reconstructor, if it has one.
+
+(define (proc->reconstructor proc)      
+  (cond ((name-node? proc)
+	 (let ((probe (node-ref proc 'binding)))
+	   (if (and probe
+		    (binding? probe)
+		    (primop? (binding-static probe)))
+	       (table-ref primop-reconstructors
+			  (binding-static probe))
+	       #f)))
+	((literal-node? proc)
+	 (if (primop? (node-form proc))
+	     (table-ref primop-reconstructors
+			(node-form proc))
+	     #f))
+	(else #f)))
+
+(define (reconstruct-call form constrained want-type)
+  (let* ((want-op-type (procedure-type any-arguments-type
+				       want-type
+				       #f))
+	 (op-type (if (lambda-node? (car form))
+		      (reconstruct-lambda (car form)
+					  constrained
+					  want-op-type
+					  #t)
+		      (reconstruct (car form)
+				   constrained
+				   want-op-type)))
+	 (args (cdr form))
+	 (lose (lambda ()
+		 (for-each (lambda (arg)
+			     (examine arg constrained value-type))
+			   args))))
+    (if (procedure-type? op-type)
+	(begin (if (restrictive? op-type)
+		   (let loop ((args args)
+			      (dom (procedure-type-domain op-type)))
+		     (if (not (or (null? args)
+				  (empty-rail-type? dom)))
+			 (begin (examine (car args)
+					 constrained
+					 (head-type dom))
+				(loop (cdr args) (tail-type dom)))))
+		   (lose))
+	       (procedure-type-codomain op-type))
+	(begin (lose)
+	       any-values-type))))
+
+(define-reconstructor 'literal 'leaf
+  (lambda (node constrained want-type)
+    (constant-type (node-form node))))
+
+(define-reconstructor 'quote syntax-type
+  (lambda (node constrained want-type)
+    (constant-type (cadr (node-form node)))))
+
+(define-reconstructor 'unspecific #f
+  (lambda (node constrained wnat-type)
+    unspecific-type))
+
+(define-reconstructor 'unassigned #f
+  (lambda (node constrained wnat-type)
+    unspecific-type))
+
+(define-reconstructor 'if syntax-type
+  (lambda (node constrained want-type)
+    (let ((form (node-form node)))
+      (examine (cadr form) constrained value-type)
+      ;; Fork off two different constrain sets
+      (let ((con-alist (fork-constraints constrained))
+            (alt-alist (fork-constraints constrained)))
+        (let ((con-type (reconstruct (caddr form) con-alist want-type))
+              (alt-type (reconstruct (cadddr form) alt-alist want-type)))
+          (if (pair? constrained)
+              (for-each (lambda (c1 c2 c)
+                          (set-cdr! c (join-type (cdr c1) (cdr c2))))
+                        con-alist
+                        alt-alist
+                        constrained))
+          (join-type con-type alt-type))))))
+
+(define (fork-constraints constrained)
+  (if (pair? constrained)
+      (map (lambda (x) (cons (car x) (cdr x)))
+           constrained)
+      constrained))-
+
+(define-reconstructor 'begin syntax-type
+  (lambda (node constrained want-type)
+    ;; This is unsound - there might be a throw out of some subform
+    ;; other than the final one.
+    (do ((forms (cdr (node-form node)) (cdr forms)))
+        ((null? (cdr forms))
+         (reconstruct (car forms) constrained want-type))
+      (examine (car forms) constrained any-values-type))))
+
+(define-reconstructor 'set! syntax-type
+  (lambda (node constrained want-type)
+    (examine (caddr (node-form node)) constrained value-type)
+    unspecific-type))
+
+(define-reconstructor 'letrec syntax-type
+  (lambda (node constrained want-type)
+    (let ((form (node-form node)))
+      (if (eq? constrained 'fast)
+          (reconstruct (caddr form) 'fast want-type)
+          (let ((alist (map (lambda (spec)
+			      (cons (car spec)
+				    (reconstruct (cadr spec)
+						 constrained
+						 value-type)))
+                            (cadr form))))
+            (reconstruct (caddr form)
+			 (append alist constrained)
+                         want-type))))))
+
+(define-reconstructor 'loophole syntax-type
+  (lambda (node constrained want-type)
+    (let ((args (cdr (node-form node))))
+      (examine (cadr args) constrained any-values-type)
+      (car args))))
+
+(define (node->type node)
+  (if (node? node)
+      (let ((form (node-form node)))
+        (if (pair? form)
+            (map node->type form)
+            (desyntaxify form)))
+      (desyntaxify node)))
+
+(define-reconstructor 'define syntax-type
+  (lambda (node constrained want-type)
+    ':definition))
+
+(define-reconstructor 'lap syntax-type
+  (lambda (node constrained want-type)
+    any-procedure-type))
+
+(define name-node?    (node-predicate 'name    'leaf))
+(define lambda-node?  (node-predicate 'lambda  syntax-type))
+(define literal-node? (node-predicate 'literal 'leaf))
+; --------------------
+; Primops.
+;
+; Most primops just have the types assigned in comp-prim.scm.
+
+(define primop-reconstructors (make-symbol-table))
+
+(define (define-primop-reconstructor name proc)
+  (table-set! primop-reconstructors name proc))
+
+(define-reconstructor 'primitive-procedure syntax-type
+  (lambda (node constrained want-type)
+    (primop-type (get-primop (cadr (node-form node))))))
+
+(define-primop-reconstructor 'values
+  (lambda (args constrained want-type)
+    (make-some-values-type (map (lambda (node)
+                                  (meet-type
+                                   (reconstruct node constrained value-type)
+                                   value-type))
+				args))))
+
+(define-primop-reconstructor 'call-with-values
+  (lambda (args constrained want-type)
+    (if (= (length args) 2)
+	(let ((thunk-type (reconstruct (car args)
+				       constrained
+				       (procedure-type empty-rail-type
+						       any-values-type
+						       #f))))
+	  (careful-codomain
+	   (reconstruct (cadr args)
+			constrained
+			(procedure-type (careful-codomain thunk-type)
+					any-values-type
+					#f))))
+	error-type)))
+
+(define (reconstruct-apply args constrained want-type)
+  (if (not (null? args))
+      (let ((proc-type (reconstruct (car args)
+				    constrained
+				    any-procedure-type)))
+	(for-each (lambda (arg) (examine arg constrained value-type))
+		  (cdr args))
+	(careful-codomain proc-type))
+      error-type))
+
+(define-primop-reconstructor 'apply reconstruct-apply)
+
+(define-primop-reconstructor 'primitive-catch reconstruct-apply)
+
+(define (constant-type x)
+  (cond ((number? x)
+         (meet-type (if (exact? x) exact-type inexact-type)
+                    (cond ((integer? x) integer-type)
+                          ((rational? x) rational-type)
+                          ((real? x) real-type)
+                          ((complex? x) complex-type)
+                          (else number-type))))
+        ((boolean? x) boolean-type)
+        ((pair? x) pair-type)
+        ((string? x) string-type)
+        ((char? x) char-type)
+        ((null? x) null-type)
+        ((symbol? x) symbol-type)
+        ((vector? x) vector-type)
+        (else value-type)))
+
diff --git a/scheme/bcomp/rules.scm b/scheme/bcomp/rules.scm
new file mode 100644
index 0000000..02dd860
--- /dev/null
+++ b/scheme/bcomp/rules.scm
@@ -0,0 +1,278 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; The syntax-rules macro (new in R5RS)
+
+; Example:
+;
+; (define-syntax or
+;   (syntax-rules ()
+;     ((or)          #f)
+;     ((or e)        e)
+;     ((or e1 e ...) (let ((temp e1))
+;		       (if temp temp (or e ...))))))
+
+(define-usual-macro 'syntax-rules
+  (lambda (exp r c)
+    (if (pair? (cdr exp))
+        (let ((subkeywords (cadr exp))
+              (rules (cddr exp)))
+       (if (and (list? subkeywords)
+                   (every name? subkeywords))
+       ;; Pair of the procedure and list of auxiliary names
+          `(,(r 'cons)              ;should be 'transformer
+               ,(process-rules rules subkeywords r c)
+                (,(r 'quote)
+           ,(find-free-names-in-syntax-rules subkeywords rules)))
+             exp))
+   exp))
+  '(append and car cdr cond cons else eq? equal? lambda let let* map
+	   pair? quote values))
+
+
+(define (process-rules rules subkeywords r c)
+
+  (define %append (r 'append))
+  (define %apply (r 'apply))
+  (define %and (r 'and))
+  (define %car (r 'car))
+  (define %cdr (r 'cdr))
+  (define %compare (r 'compare))
+  (define %cond (r 'cond))
+  (define %cons (r 'cons))
+  (define %else (r 'else))
+  (define %eq? (r 'eq?))
+  (define %equal? (r 'equal?))
+  (define %input (r 'input))
+  (define %lambda (r 'lambda))
+  (define %let (r 'let))
+  (define %let* (r 'let*))
+  (define %map (r 'map))
+  (define %pair? (r 'pair?))
+  (define %quote (r 'quote))
+  (define %rename (r 'rename))
+  (define %tail (r 'tail))
+  (define %temp (r 'temp))
+
+  (define (make-transformer rules)
+    `(,%lambda (,%input ,%rename ,%compare)
+       (,%let ((,%tail (,%cdr ,%input)))
+	 (,%cond ,@(map process-rule rules)
+		 (,%else ,%input)))))       ;Error when left unchanged.
+
+  (define (process-rule rule)
+    (if (and (pair? rule)
+	     (pair? (cdr rule))
+	     (null? (cddr rule)))
+	(let ((pattern (cdar rule))
+	      (template (cadr rule)))
+	  `((,%and ,@(process-match %tail pattern))
+	    (,%let* ,(process-pattern pattern
+				      %tail
+				      (lambda (x) x))
+		    ,(process-template template
+				       0
+				       (meta-variables pattern 0 '())))))
+	(syntax-error "ill-formed syntax rule" rule)))
+
+  ; Generate code to test whether input expression matches pattern
+
+  (define (process-match input pattern)
+    (cond ((name? pattern)
+	   (if (member pattern subkeywords)
+	       `((,%compare ,input (,%rename ',pattern)))
+	       `()))
+	  ((segment-pattern? pattern)
+	   (process-segment-match input (car pattern)))
+	  ((pair? pattern)
+	   `((,%let ((,%temp ,input))
+	       (,%and (,%pair? ,%temp)
+		    ,@(process-match `(,%car ,%temp) (car pattern))
+		    ,@(process-match `(,%cdr ,%temp) (cdr pattern))))))
+	  ((or (null? pattern) (boolean? pattern) (char? pattern))
+	   `((,%eq? ,input ',pattern)))
+	  (else
+	   `((,%equal? ,input ',pattern)))))
+
+  (define (process-segment-match input pattern)
+    (let ((conjuncts (process-match '(car l) pattern)))
+      (if (null? conjuncts)
+	  `((list? ,input))			;+++
+	  `((let loop ((l ,input))
+	      (or (null? l)
+		  (and (pair? l)
+		       ,@conjuncts
+		       (loop (cdr l)))))))))
+
+  ; Generate code to take apart the input expression
+  ; This is pretty bad, but it seems to work (can't say why).
+
+  (define (process-pattern pattern path mapit)
+    (cond ((name? pattern)
+	   (if (memq pattern subkeywords)
+	       '()
+	       (list (list pattern (mapit path)))))
+	  ((segment-pattern? pattern)
+	   (process-pattern (car pattern)
+			    %temp
+			    (lambda (x)	;temp is free in x
+			      (mapit (if (eq? %temp x)
+					 path ;+++
+					 `(,%map (,%lambda (,%temp) ,x)
+						 ,path))))))
+	  ((pair? pattern)
+	   (append (process-pattern (car pattern) `(,%car ,path) mapit)
+		   (process-pattern (cdr pattern) `(,%cdr ,path) mapit)))
+	  (else '())))
+
+  ; Generate code to compose the output expression according to template
+
+  (define (process-template template dim env)
+    (cond ((name? template)
+	   (let ((probe (assq template env)))
+	     (if probe
+		 (if (<= (cdr probe) dim)
+		     template
+		     (syntax-error "template dimension error (too few ...'s?)"
+				   template))
+		 `(,%rename ',template))))
+	  ((segment-template? template)
+	   (let* ((depth (segment-depth template))
+		  (seg-dim (+ dim depth))
+		  (vars
+		   (free-meta-variables (car template) seg-dim env '())))
+	     (if (null? vars)
+		 (syntax-error "too many ...'s" template)
+		 (let* ((x (process-template (car template)
+					     seg-dim
+					     env))
+			(gen (if (equal? (list x) vars)
+				 x	;+++
+				 `(,%map (,%lambda ,vars ,x)
+					 ,@vars)))
+			(gen (do ((d depth (- d 1))
+				  (gen gen `(,%apply ,%append ,gen)))
+				 ((= d 1)
+				  gen))))
+		   (if (null? (segment-tail template))
+		       gen		;+++
+		       `(,%append ,gen ,(process-template (segment-tail template)
+							  dim env)))))))
+	  ((pair? template)
+	   `(,%cons ,(process-template (car template) dim env)
+		    ,(process-template (cdr template) dim env)))
+	  (else `(,%quote ,template))))
+
+  ; Return an association list of (var . dim)
+
+  (define (meta-variables pattern dim vars)
+    (cond ((name? pattern)
+	   (if (memq pattern subkeywords)
+	       vars
+	       (cons (cons pattern dim) vars)))
+	  ((segment-pattern? pattern)
+	   (meta-variables (car pattern) (+ dim 1) vars))
+	  ((pair? pattern)
+	   (meta-variables (car pattern) dim
+			   (meta-variables (cdr pattern) dim vars)))
+	  (else vars)))
+
+  ; Return a list of meta-variables of given higher dim
+
+  (define (free-meta-variables template dim env free)
+    (cond ((name? template)
+	   (if (and (not (memq template free))
+		    (let ((probe (assq template env)))
+		      (and probe (>= (cdr probe) dim))))
+	       (cons template free)
+	       free))
+	  ((segment-template? template)
+	   (free-meta-variables (car template)
+				dim env
+				(free-meta-variables (cddr template)
+						     dim env free)))
+	  ((pair? template)
+	   (free-meta-variables (car template)
+				dim env
+				(free-meta-variables (cdr template)
+						     dim env free)))
+	  (else free)))
+
+  (make-transformer rules))
+
+(define (segment-pattern? pattern)
+  (and (segment-template? pattern)
+       (or (null? (cddr pattern))
+	   (syntax-error "segment matching not implemented" pattern))))
+
+(define (segment-template? pattern)
+  (and (pair? pattern)
+       (pair? (cdr pattern))
+       (memq (cadr pattern) indicators-for-zero-or-more)))
+
+; Count the number of `...'s in PATTERN.
+
+(define (segment-depth pattern)
+  (if (segment-template? pattern)
+      (+ 1 (segment-depth (cdr pattern)))
+      0))
+
+; Get whatever is after the `...'s in PATTERN.
+
+(define (segment-tail pattern)
+  (let loop ((pattern (cdr pattern)))
+    (if (and (pair? pattern)
+             (memq (car pattern) indicators-for-zero-or-more))
+        (loop (cdr pattern))
+        pattern)))
+
+(define indicators-for-zero-or-more (list (string->symbol "...")))
+
+;(define (name? thing)
+;  (or (symbol? thing)
+;      (not (or (pair? thing)            ;Kludge!
+;               (null? thing)
+;               (number? thing)
+;               (boolean? thing)
+;               (char? thing)
+;               (string? thing)))))
+
+; The following is used by Scheme 48's static linker.
+
+(define (find-free-names-in-syntax-rules subkeywords rules)
+
+  (define (meta-variables pattern vars)
+    (cond ((name? pattern)
+	   (if (memq pattern subkeywords)
+	       vars
+	       (cons pattern vars)))
+	  ((segment-pattern? pattern)
+	   (meta-variables (car pattern) ;vars
+			   (meta-variables (cddr pattern) vars)))
+	  ((pair? pattern)
+	   (meta-variables (car pattern)
+			   (meta-variables (cdr pattern) vars)))
+	  (else vars)))
+
+  (define (free-names template vars names)
+    (cond ((name? template)
+	   (if (or (memq template vars)
+		   (memq template names))
+	       names
+	       (cons template names)))
+	  ((segment-template? template)
+	   (free-names (car template)
+		       vars
+		       (free-names (cddr template) vars names)))
+	  ((pair? template)
+	   (free-names (car template)
+		       vars
+		       (free-names (cdr template) vars names)))
+	  (else names)))
+
+  (do ((rules rules (cdr rules))
+       (names subkeywords
+	      (let ((rule (car rules)))
+		(free-names (cadr rule)
+			    (meta-variables (cdar rule) '())
+			    names))))
+      ((null? rules) names)))
diff --git a/scheme/bcomp/scan-package.scm b/scheme/bcomp/scan-package.scm
new file mode 100644
index 0000000..fd5efb7
--- /dev/null
+++ b/scheme/bcomp/scan-package.scm
@@ -0,0 +1,126 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Scanning structures and processing package clauses.
+
+; Utility for compile-structures (link/link.scm) and
+; ensure-loaded (env/load-package.scm).
+;
+; Returns a list of all packages reachable from STRUCTS that answer true to
+; INCLUDE-THIS-PACKAGE?.
+
+(define (collect-packages structs include-this-package?)
+  (let ((package-seen '())
+	(structure-seen '())
+	(packages '()))
+    (letrec ((recur
+	      (lambda (structure)
+		(if (not (memq structure structure-seen))
+		    (begin
+		      (set! structure-seen (cons structure structure-seen))
+		      (let ((package (structure-package structure)))
+			(if (not (memq package package-seen))
+			    (begin
+			      (set! package-seen (cons package package-seen))
+			      (if (include-this-package? package)
+				  (begin
+				    (for-each recur (package-opens package))
+				    (for-each (lambda (name+struct)
+						(recur (cdr name+struct)))
+					      (package-accesses package))
+				    (set! packages (cons package packages))))))))))))
+      (for-each recur structs)
+      (reverse packages))))
+
+; Walk through PACKAGE's clauses to find the source code.  The relevent
+; clauses are:
+;   (file name ...)
+;   (begin form ...)
+;   (define-all-operators)
+;   (usual-transforms)
+;
+; Returns a list of pairs (file . (node1 node2 ...)), a list of names
+; of standard transforms, and a boolean value which is true if the package
+; is to include definitions of all primitives.
+
+(define (package-source package)
+  (let* ((config-file (package-file-name package))
+	 (dir (if config-file
+		  (file-name-directory config-file)
+		  #f)))
+    (fold->3 (lambda (clause stuff transforms primitives?)
+	       (case (car clause)
+		 ((files)
+		  (values (read-files (cdr clause) stuff dir package)
+			  transforms
+			  primitives?))
+		 ((begin)
+		  (values (cons (cons config-file (cdr clause))
+				stuff)
+			  transforms
+			  primitives?))
+		 ((integrate)
+		  (set-package-integrate?! package
+					   (or (null? (cdr clause))
+					       (cadr clause)))
+		  (values stuff transforms primitives?))
+		 ((optimize)
+		  (values stuff transforms primitives?))
+		 ((define-all-operators)
+		  (values stuff transforms #t))
+		 ((usual-transforms)
+		  (values stuff
+			  (append (cdr clause) transforms)
+			  primitives?))
+		 (else
+		  (error "unrecognized define-structure keyword"
+			 clause))))
+	     (reverse (package-clauses package))
+	     '() '() #f)))
+
+; Also prints out the filenames (courtesy of READ-FORMS).
+
+(define (read-files all-files stuff dir package)
+  (force-output (current-output-port))		; just to be nice
+  (fold (lambda (filespec stuff)
+	  (let ((file (namestring filespec
+				  dir
+				  *scheme-file-type*)))
+	    (display #\space (current-noise-port))
+	    (cons (cons file (read-forms file package))
+		  stuff)))
+	(reverse all-files)
+	stuff))
+
+(define (package-optimizer-names package)
+  (if (package-integrate? package)
+      (let ((opts (apply append
+			 (map cdr (filter (lambda (clause)
+					    (eq? (car clause) 'optimize))
+					  (package-clauses package))))))
+	(reduce (lambda (name opts)
+		  (if (memq name opts)
+		      opts
+		      (cons name opts)))
+		opts
+		'()))
+      '()))
+
+(define (check-structure structure)
+  (let ((undefined '()))
+    (for-each-export
+         (lambda (name want-type binding)
+	   (if (binding? binding)
+	       (let ((have-type (binding-type binding)))
+		 (if (not (compatible-types? have-type want-type))
+		     (warn "Type in interface doesn't match binding"
+			   name
+			   `(binding: ,(type->sexp have-type #t))
+			   `(interface: ,(type->sexp want-type #t))
+			   structure)))
+	       (set! undefined (cons name undefined))))
+	 structure)
+    (if (not (null? undefined))
+	(warn "Structure has undefined exports"
+	      structure
+	      undefined))))
+
diff --git a/scheme/bcomp/schemify.scm b/scheme/bcomp/schemify.scm
new file mode 100644
index 0000000..623b94f
--- /dev/null
+++ b/scheme/bcomp/schemify.scm
@@ -0,0 +1,141 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; schemify
+
+; This is only used for producing error and warning messages.
+
+; Flush nodes and generated names in favor of something a little more
+; readable.  Eventually, (schemify node env) ought to produce an
+; s-expression that has the same semantics as node, when node is fully
+; expanded.
+
+(define (schemify node . maybe-env)
+  (if (node? node)
+      (schemify-node node
+		     (if (null? maybe-env)
+			 #f
+			 (car maybe-env)))
+      (schemify-sexp node)))
+		     
+
+(define schemifiers
+  (make-operator-table (lambda (node env)
+			 (let ((form (node-form node)))
+			   (if (list? form)
+			       (let ((op (car form)))
+				 (cons (cond ((operator? op)
+					      (operator-name op))
+					     ((node? op)
+					      (schemify-node op env))
+					     (else
+					      (schemify-sexp op)))
+				       (schemify-nodes (cdr form) env)))
+			       form)))))
+
+; We cache the no-env version because that's the one used to generate the
+; sources in the debugging info (which takes up a lot of space).
+
+(define (schemify-node node env)
+  (or (and (not env)
+	   (node-ref node 'schemify))
+      (let ((form ((operator-table-ref schemifiers (node-operator-id node))
+		     node
+		     env)))
+	(if (not env)
+	    (node-set! node 'schemify form))
+	form)))
+
+(define (schemify-nodes nodes env)
+  (map (lambda (node)
+	 (schemify-node node env))
+       nodes))
+
+(define (define-schemifier name type proc)
+  (operator-define! schemifiers name type proc))
+
+(define-schemifier 'name 'leaf
+  (lambda (node env)
+    (if env
+	(name->qualified (node-form node)
+			 env)
+	(desyntaxify (node-form node)))))
+
+(define-schemifier 'quote syntax-type
+  (lambda (node env)
+    (let ((form (node-form node)))
+      `(quote ,(cadr form)))))
+
+(define-schemifier 'call 'internal
+  (lambda (node env)
+    (map (lambda (node)
+	   (schemify-node node env))
+	 (node-form node))))
+
+; We ignore the list of free variables in flat lambdas.
+
+(define (schemify-lambda node env)
+  (let ((form (node-form node)))
+    `(lambda ,(schemify-formals (cadr form) env)
+       ,(schemify-node (last form) env))))
+
+(define-schemifier 'lambda syntax-type schemify-lambda)
+(define-schemifier 'flat-lambda syntax-type schemify-lambda)
+
+(define (schemify-formals formals env)
+  (cond ((node? formals)
+	 (schemify-node formals env))
+	((pair? formals)
+	 (cons (schemify-node (car formals) env)
+	       (schemify-formals (cdr formals) env)))
+	(else
+	 (schemify-sexp formals))))  ; anything besides '() ?
+
+; let-syntax, letrec-syntax...
+
+(define-schemifier 'letrec syntax-type
+  (lambda (node env)
+    (let ((form (node-form node)))
+      `(letrec ,(map (lambda (spec)
+		       (schemify-nodes spec env))
+		     (cadr form))
+	 ,@(map (lambda (f) (schemify-node f env))
+		(cddr form))))))
+
+(define-schemifier 'loophole syntax-type
+  (lambda (node env)
+    (let ((form (node-form node)))
+      (list 'loophole
+	    (type->sexp (cadr form) #t)
+	    (schemify-node (caddr form) env)))))
+
+(define-schemifier 'lap syntax-type
+  (lambda (node env)
+    (let ((form (node-form node)))
+      `(lap
+	,(cadr form)
+	,(schemify-nodes (caddr form) env)
+	. ,(cdddr form)))))
+
+;----------------
+
+(define (schemify-sexp thing)
+  (cond ((name? thing)
+	 (desyntaxify thing))
+	((pair? thing)
+	 (let ((x (schemify-sexp (car thing)))
+	       (y (schemify-sexp (cdr thing))))
+	   (if (and (eq? x (car thing))
+		    (eq? y (cdr thing)))
+	       thing			;+++
+	       (cons x y))))
+	((vector? thing)
+	 (let ((new (make-vector (vector-length thing) #f)))
+	   (let loop ((i 0) (same? #t))
+	     (if (>= i (vector-length thing))
+		 (if same? thing new)	;+++
+		 (let ((x (schemify-sexp (vector-ref thing i))))
+		   (vector-set! new i x)
+		   (loop (+ i 1)
+			 (and same? (eq? x (vector-ref thing i)))))))))
+	(else thing)))
+
diff --git a/scheme/bcomp/segment.scm b/scheme/bcomp/segment.scm
new file mode 100644
index 0000000..bd62511
--- /dev/null
+++ b/scheme/bcomp/segment.scm
@@ -0,0 +1,331 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; The byte code compiler's assembly phase.
+
+(define make-segment cons)
+(define segment-size car);number of bytes that will be taken in the code vector
+(define segment-emitter cdr)
+
+(define (segment->template segment name pc-in-parent parent-data)
+  (let* ((cv (make-code-vector (segment-size segment) 0))
+	 (astate (make-astate cv))
+	 (name (if (if (string? name)	; only files have strings for names
+		       (keep-file-names?)
+		       (keep-procedure-names?))
+		   name
+		   #f))
+	 (debug-data (new-debug-data name parent-data pc-in-parent)))
+    (let-fluid $debug-data debug-data
+      (lambda ()
+	(let* ((maps (emit-with-environment-maps! astate segment))
+	       (cv (check-stack-use cv)))
+	  (set-debug-data-env-maps! debug-data maps)
+	  (make-immutable! cv)
+	  (segment-data->template cv
+				  (debug-data->info debug-data)
+				  (reverse (astate-literals astate))))))))
+
+(define (segment-data->template cv debug-data literals)
+  (let ((template (make-template (+ template-overhead (length literals)) 0)))
+    (set-template-code! template cv)
+    (set-template-info! template debug-data)
+    (do ((lits literals (cdr lits))
+	 (i template-overhead (+ i 1)))
+	((null? lits) template)
+      (template-set! template i (car lits)))
+    template))
+
+; If CV needs more than the default allotment of stack space replace its
+; protocol with one that checks that the needed space is available.  The
+; original protocol is preserved at the end of the new code vector (to
+; preserve the debugging indicies into the original).
+
+(define (check-stack-use cv)
+  (let ((uses (maximum-stack-use cv)))
+    (cond ((<= uses default-stack-space)
+	   cv)
+	  ((<= uses available-stack-space)
+	   (let* ((length (code-vector-length cv))
+		  (new (make-code-vector (+ length 3) 0)))
+	     (do ((i 0 (+ i 1)))
+		 ((= i length))
+	       (code-vector-set! new i (code-vector-ref cv i)))
+	     (code-vector-set! new length (code-vector-ref cv 1))
+	     (code-vector-set! new 1 big-stack-protocol)
+	     (code-vector-set2! new (+ length 1) uses)
+	     new))
+	  (else
+	   (error "VM limit exceeded: procedure requires too much stack space")))))
+
+; "astate" is short for "assembly state"
+
+(define-record-type assembly-state :assembly-state
+  (make-assembly-state cv pc count lits)
+  (cv    astate-code-vector)
+  (pc    astate-pc    set-astate-pc!)
+  (count astate-count set-astate-count!)
+  (lits  astate-literals  set-astate-literals!))
+
+(define (make-astate cv)
+  (make-assembly-state cv 0 template-overhead '()))
+
+(define (emit-byte! a byte)
+  (code-vector-set! (astate-code-vector a) (astate-pc a) byte)
+  (set-astate-pc! a (+ (astate-pc a) 1)))
+
+(define (literal->index a thing)
+  (let ((probe (literal-position thing (astate-literals a)))
+	(count (astate-count a)))
+    (if probe
+	;; +++  Eliminate duplicate entries.
+	;; Not necessary, just a modest space saver [how much?].
+	;; Measurably slows down compilation.
+	;; when 1 thing, lits = (x), count = 3, probe = 0, want 2
+	(- (- count probe) 1)
+	(begin
+	  (if (>= count two-byte-limit)
+	      (error "compiler bug: too many literals"
+		     thing))
+	  (set-astate-literals! a (cons thing (astate-literals a)))
+	  (set-astate-count! a (+ count 1))
+	  count))))
+
+(define (literal-position thing literals)
+  (position (if (thingie? thing)
+		(lambda (thing other-thing)
+		  (and (thingie? other-thing)
+		       (equal? (thingie-name thing)
+			       (thingie-name other-thing))))
+		equal?)
+	    thing
+	    literals))
+
+(define (position pred elt list)
+  (let loop ((i 0) (l list))
+    (cond ((null? l)
+	   #f)
+	  ((pred elt (car l))
+	   i)
+	  (else
+	   (loop (+ i 1) (cdr l))))))
+
+(define (emit-literal! a thing)
+  (let ((index (literal->index a thing)))
+    (emit-byte! a (high-byte index))
+    (emit-byte! a (low-byte index))))
+
+(define (emit-segment! astate segment)
+  ((segment-emitter segment) astate))
+
+; Segment constructors
+
+(define empty-segment
+  (make-segment 0 (lambda (astate) #f)))
+
+(define (instruction opcode . operands)
+  (make-segment (+ 1 (length operands))
+		(lambda (astate)
+		  (emit-byte! astate opcode)
+		  (for-each (lambda (operand)
+			      (emit-byte! astate operand))
+			    operands))))
+
+(define (sequentially . segments)
+  ;;  (reduce sequentially-2 empty-segment segments)
+  ;;+++ this sped the entire compilation process up by several percent
+  (cond ((null? segments)
+         empty-segment)
+        ((null? (cdr segments))
+         (car segments))
+        ((null? (cddr segments))
+         (sequentially-2 (car segments) (cadr segments)))
+        (else
+         (make-segment (let loop ((segs segments) (s 0))
+                         (if (null? segs)
+                             s
+                             (loop (cdr segs) (+ s (segment-size (car segs))))))
+                       (lambda (astate)
+                         (let loop ((segs segments))
+                           (if (not (null? segs))
+                               (begin (emit-segment! astate (car segs))
+                                      (loop (cdr segs))))))))))
+
+(define (sequentially-2 seg1 seg2)
+  (cond ((eq? seg1 empty-segment) seg2) ;+++ speed up the compiler a tad
+	((eq? seg2 empty-segment) seg1) ;+++
+	(else
+	 (make-segment (+ (segment-size seg1)
+			  (segment-size seg2))
+		       (lambda (astate)
+			 (emit-segment! astate seg1)
+			 (emit-segment! astate seg2)))))) ;tail call
+
+; Literals are obtained from the template.
+
+(define (instruction-with-literal opcode thing . operands)
+  (make-segment (+ 3 (length operands))
+		(lambda (astate)
+		  (let ((index (literal->index astate thing)))
+		    (if (and (= opcode (enum op literal))
+                             (< index byte-limit))
+			(begin
+			  (emit-byte! astate (enum op small-literal))
+			  (emit-byte! astate index)
+			  (emit-byte! astate 0))
+			(begin
+			  (emit-byte! astate opcode)
+			  (emit-byte! astate (high-byte index))
+			  (emit-byte! astate (low-byte index))))
+		    (for-each (lambda (operand)
+				(emit-byte! astate operand))
+			      operands)))))
+
+; So are locations.
+
+(define (instruction-with-location opcode binding name want-type)
+  (make-segment 3
+		(lambda (astate)
+		  (emit-byte! astate opcode)
+		  (emit-literal! astate (make-thingie binding name want-type)))))
+
+; Templates for inferior closures are also obtained from the
+; (parent's) template.
+
+(define (template segment name)
+  (make-segment 2
+  		(lambda (astate)
+  		  (emit-literal! astate
+  				 (segment->template segment
+  						    name
+						    (astate-pc astate)
+						    (fluid $debug-data))))))
+
+; Labels.  Each label maintains a list of pairs (location . origin).
+; Instr is the index of the first of two bytes that will hold the jump
+; target offset, and the offset stored will be (- jump-target origin).
+;
+; The car of a forward label is #F, the car of a backward label is the
+; label's PC.
+
+(define (make-label) (list #f))
+
+(define (instruction-using-label opcode label . rest)
+  (let ((segment (apply instruction opcode 0 0 rest)))
+    (make-segment (segment-size segment)
+		  (lambda (astate)
+		    (let* ((origin (astate-pc astate))
+			   (location (+ origin 1)))
+		      (emit-segment! astate segment)
+		      (if (car label)
+			  (insert-label! (astate-code-vector astate)
+					 location
+					 (- (car label) origin))
+			  (set-cdr! label
+				    (cons (cons location origin)
+					  (cdr label)))))))))
+
+; computed-goto
+; # of labels
+; label0
+; label1
+; ...
+
+(define computed-goto-label-size 2)
+
+(define (computed-goto-instruction labels)
+  (let* ((count (length labels))
+	 (segment (instruction (enum op computed-goto) count)))
+    (make-segment (+ (segment-size segment)
+		     (* count computed-goto-label-size))
+		  (lambda (astate)
+		    (let ((base-address (astate-pc astate)))
+		      (emit-segment! astate segment)
+		      (set-astate-pc! astate
+				      (+ (astate-pc astate)
+					 (* count computed-goto-label-size)))
+		      (do ((location (+ base-address 2)
+				     (+ location computed-goto-label-size))
+			   (labels labels (cdr labels)))
+			  ((null? labels))
+			(let ((label (car labels)))
+			  (if (car label)
+			      (warn "backward jumps not supported")
+			      (set-cdr! label
+					(cons (cons location base-address)
+					      (cdr label)))))))))))
+
+; LABEL is the label for SEGMENT.  The current PC is used as the value of LABEL.
+
+(define (attach-label label segment)
+  (make-segment
+     (segment-size segment)
+     (lambda (astate)
+       (let ((pc (astate-pc astate))
+	     (cv (astate-code-vector astate)))
+	 (for-each (lambda (instr+origin)
+		     (insert-label! cv
+				    (car instr+origin)
+				    (- pc (cdr instr+origin))))
+		   (cdr label))
+	 (set-car! label pc)
+	 (emit-segment! astate segment)))))
+
+(define (insert-label! cv location offset)
+  (code-vector-set2! cv location offset))
+
+(define (code-vector-set2! cv i value)
+  (code-vector-set! cv i       (high-byte value))
+  (code-vector-set! cv (+ i 1) (low-byte  value)))
+
+(define two-byte-limit (expt 2 (* 2 bits-used-per-byte)))
+
+(define (high-byte n)
+  (quotient n byte-limit))
+
+(define (low-byte n)
+  (remainder n byte-limit))
+
+; Special segments for maintaining debugging information.  Not
+; essential for proper functioning of compiler.
+
+(define $debug-data (make-fluid #f))
+
+; Keep track of source code at continuations.
+
+(define (note-source-code info segment)
+  (make-segment (segment-size segment)
+		(lambda (astate)
+		  (emit-segment! astate segment)
+		  (let ((dd (fluid $debug-data)))
+		    (set-debug-data-source!
+		     dd
+		     (cons (cons (astate-pc astate) info)
+			   (debug-data-source dd)))))))
+
+; Keep track of variable names from lexical environments.
+; Each environment map has the form
+;    #(pc-before pc-after (var ...) (env-map ...))
+
+(define (note-environment vars segment)
+  (if (keep-environment-maps?)
+      (make-segment (segment-size segment)
+		    (lambda (astate)
+		      (let* ((pc-before (astate-pc astate))
+			     (env-maps
+			      (emit-with-environment-maps! astate segment)))
+			(set-fluid! $environment-maps
+				    (cons (vector pc-before
+						  (astate-pc astate)
+						  (list->vector vars)
+						  env-maps)
+					  (fluid $environment-maps))))))
+      segment))
+
+(define (emit-with-environment-maps! astate segment)
+  (let-fluid $environment-maps '()
+    (lambda ()
+      (emit-segment! astate segment)
+      (fluid $environment-maps))))
+
+(define $environment-maps (make-fluid '()))
diff --git a/scheme/bcomp/stack-check.scm b/scheme/bcomp/stack-check.scm
new file mode 100644
index 0000000..47c7259
--- /dev/null
+++ b/scheme/bcomp/stack-check.scm
@@ -0,0 +1,284 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; This determines the maximum stack depth needed by a code vector.
+
+(define (maximum-stack-use code-vector)
+  (cond ((not (= (code-vector-ref code-vector 0)
+		 (enum op protocol)))
+	 0)
+	((= (code-vector-ref code-vector 1)
+	    nary-dispatch-protocol)		; has unjumped-to targets
+	 (stack-max code-vector
+		    6
+		    0
+		    0
+		    (do ((i 2 (+ i 1))
+			 (r '() (let ((target (code-vector-ref code-vector i)))
+				  (if (= 0 target)
+				      r
+				      (cons (cons target 0) r)))))
+			((= i 6)
+			 r))))
+	(else
+	 (stack-max code-vector
+		    (protocol-skip code-vector)
+		    0
+		    0
+		    '()))))
+
+(define (protocol-skip code-vector)
+  (let ((protocol (code-vector-ref code-vector 1)))
+    (cond ((or (= protocol two-byte-nargs-protocol)
+	       (= protocol two-byte-nargs+list-protocol))
+	   4)
+	  ((= protocol args+nargs-protocol)
+	   3)
+	  (else
+	   2))))
+
+;----------------
+; A vector of procedures, one for each opcode.
+
+(define stack-delta (make-vector op-count #f))
+
+(define-syntax define-delta
+  (syntax-rules ()
+    ((define-delta opcode fun)
+     (vector-set! stack-delta (enum op opcode) fun))))
+
+; Handle the opcode at I.  DEPTH is the current stack depth, MAXIMUM is the
+; maximum so far, and JUMPS is a list of (<index> . <depth>) giving the stack
+; depth at jump targets.
+
+(define (stack-max code-vector i depth maximum jumps)
+  ((vector-ref stack-delta (code-vector-ref code-vector i))
+     code-vector
+     (+ i 1)
+     depth
+     maximum
+     jumps))
+
+; Do nothing and advance BYTE-SIZE bytes.
+
+(define (nothing byte-size)
+  (lambda (code-vector i depth maximum jumps)
+    (stack-max code-vector
+	       (+ i byte-size)
+	       depth
+	       maximum
+	       jumps)))
+
+; Pop COUNT values from the stack and advance BYTE-SIZE bytes.
+
+(define (popper count byte-args)
+  (lambda (code-vector i depth maximum jumps)
+    (stack-max code-vector
+	       (+ i byte-args)
+	       (- depth count)
+	       maximum
+	       jumps)))
+
+; Push COUNT values onto the stack and advance BYTE-SIZE bytes.
+
+(define (pusher count byte-args)
+  (lambda (code-vector i depth maximum jumps)
+    (stack-max code-vector
+	       (+ i byte-args)
+	       (+ depth count)
+	       (imax maximum (+ depth count))
+	       jumps)))
+
+; Continue on at opcode I.  This is used for opcodes that do not fall through
+; to the next instruction.  I is either the end of the code vector or the target
+; of a jump or continuation.
+
+(define (continue code-vector i maximum jumps)
+  (cond ((= i (code-vector-length code-vector))
+	 maximum)
+	((assq i jumps)
+	 => (lambda (pair)
+	      (stack-max code-vector i (cdr pair) maximum jumps)))
+	(else
+	 (error "stack-max: no one jumps to target" i))))
+
+; Skip BYTE-ARGS and then continue.
+
+(define (continuer byte-args)
+  (lambda (code-vector i depth maximum jumps)
+    (continue code-vector (+ i byte-args) maximum jumps)))
+
+;----------------
+; All the special opcodes
+
+(define-delta make-env           (pusher environment-stack-size 2))
+;(define-delta push               (pusher 1 0))
+(define-delta pop                (popper 1 0))
+(define-delta call               (continuer 1))
+(define-delta big-call           (continuer 2))
+(define-delta move-args-and-call (continuer 1))
+(define-delta apply              (continuer 2))
+(define-delta closed-apply       (continuer 0))
+(define-delta with-continuation  (nothing 0))     ; what the compiler requires
+(define-delta call-with-values   (continuer 0))
+(define-delta return             (continuer 0))
+(define-delta values             (continuer 2))
+(define-delta closed-values      (continuer 0))
+(define-delta ignore-values      (nothing 0))
+(define-delta goto-template      (continuer 2))
+(define-delta call-template      (continuer 3))
+
+; We should never reach a PROTOCOL opcode.
+
+(define-delta protocol
+  (lambda stuff
+    (error "looking for protocol's stack delta")))
+
+; Peephole optimizations
+
+(define-delta push
+  (lambda (cv pc depth maximum jumps)
+    (if (= (enum op local0)
+	   (code-vector-ref cv pc))
+	(begin
+	  (code-vector-set! cv (- pc 1) (enum op push-local0))
+	  (code-vector-set! cv pc (code-vector-ref cv (+ pc 1)))
+	  (stack-max cv
+		     (+ pc 2)
+		     (+ depth 1)
+		     (imax maximum (+ depth 1))
+		     jumps))
+	(stack-max cv
+		   pc
+		   (+ depth 1)
+		   (imax maximum (+ depth 1))
+		   jumps))))
+
+(define-delta local0
+  (lambda (cv pc depth maximum jumps)
+    (if (= (enum op push)
+	   (code-vector-ref cv (+ pc 1)))
+	(begin
+	  (code-vector-set! cv (- pc 1) (enum op local0-push))
+	  (stack-max cv
+		     (+ pc 2)
+		     (+ depth 1)
+		     (imax maximum (+ depth 1))
+		     jumps))
+	(stack-max cv
+		   (+ pc 1)
+		   depth
+		   maximum
+		   jumps))))
+
+; Pop the given numbers of stack values.
+
+(define-delta make-stored-object
+  (lambda (cv pc depth maximum jumps)
+    (let ((args (code-vector-ref cv pc)))
+      (stack-max cv (+ pc 2) (- depth (- args 1)) maximum jumps))))
+
+; Skip over the environment specification.
+
+(define-delta make-flat-env
+  (lambda (code-vector i depth maximum jumps)
+    (let ((include-*val*? (= 1 (code-vector-ref code-vector i)))
+	  (count (code-vector-ref code-vector (+ i 1))))
+      (let loop ((i (+ i 2)) (count (if include-*val*? (- count 1) count)))
+	(if (= count 0)
+	    (stack-max code-vector
+		       i
+		       depth maximum jumps)
+	    (let ((level-count (code-vector-ref code-vector (+ i 1))))
+	      (loop (+ i 2 level-count)
+		    (- count level-count))))))))
+
+; Adds the target to the list of jumps.
+; The -1 is to back up over the opcode.
+
+(define (do-make-cont total-bytes)
+  (lambda (code-vector i depth maximum jumps)
+    (let ((target (+ i -1 (get-offset code-vector i))))
+      (stack-max code-vector
+		 (+ i total-bytes)  ; eat offset and size
+		 (+ depth continuation-stack-size)
+		 (max maximum (+ depth continuation-stack-size))
+		 (cons (cons target depth) jumps)))))
+
+(define-delta make-cont (do-make-cont 3))
+(define-delta make-big-cont (do-make-cont 4))
+
+; Add the jump target(s) and either fall-through or not.
+; The -1 is to back up over the opcode.
+
+(define-delta jump-if-false
+  (lambda (code-vector i depth maximum jumps)
+    (let ((target (+ i -1 (get-offset code-vector i))))
+      (stack-max code-vector
+		 (+ i 2) ; eat label
+		 depth
+		 maximum
+		 (cons (cons target depth) jumps)))))
+
+(define-delta jump
+  (lambda (code-vector i depth maximum jumps)
+    (let ((target (+ i -1 (get-offset code-vector i))))
+      (continue code-vector
+		(+ i 2)  ; eat label
+		maximum
+		(cons (cons target depth) jumps)))))
+
+(define-delta computed-goto
+  (lambda (code-vector i depth maximum jumps)
+    (let ((count (code-vector-ref code-vector i))
+	  (base (- i 1))			; back up over opcode
+	  (i (+ i 1)))
+      (let loop ((c 0) (jumps jumps))
+	(if (= c count)
+	    (stack-max code-vector
+		       (+ i (* 2 count))
+		       depth
+		       maximum
+		       jumps)
+	    (loop (+ c 1)
+		  (cons (cons (+ base (get-offset code-vector (+ i (* c 2))))
+			      depth)
+			jumps)))))))
+
+;----------------
+; Fill in the `normal' opcodes using the information in OPCODE-ARG-SPECS.
+
+(define (stack-function arg-specs)
+  (let loop ((specs arg-specs) (skip 0))
+    (cond ((null? specs)
+	   (nothing skip))
+	  ((integer? (car specs))
+	   (if (> (car specs) 1)
+	       (popper (- (car specs) 1) skip)
+	       (nothing skip)))
+	  (else
+	   (loop (cdr specs) (+ skip (arg-spec-size (car specs))))))))
+
+(define (arg-spec-size spec)
+  (case spec
+    ((nargs byte stob junk) 1)
+    ((two-bytes offset small-index index) 2)
+    (else
+     (error "unknown arg-spec" spec))))
+
+(do ((i 0 (+ i 1)))
+    ((= i (vector-length stack-delta)))
+  (if (not (vector-ref stack-delta i))
+      (vector-set! stack-delta i (stack-function (vector-ref opcode-arg-specs i)))))
+
+;----------------
+; Utilities
+
+; Much faster then Scheme's generic function.
+
+(define (imax x y)
+  (if (< x y) y x))
+
+(define (get-offset code pc)
+  (+ (* (code-vector-ref code pc)
+	byte-limit)
+     (code-vector-ref code (+ pc 1))))
diff --git a/scheme/bcomp/state.scm b/scheme/bcomp/state.scm
new file mode 100644
index 0000000..7564646
--- /dev/null
+++ b/scheme/bcomp/state.scm
@@ -0,0 +1,106 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Compiler state, including flags controlling debug data retention.
+
+
+; Package and location uids and the location name table should be here
+; as well...
+
+; Will the use of a fluid variable significantly degrade performance?
+
+(define (new-template-uid)
+  (let ((uid *template-uid*))
+    (set! *template-uid* (+ *template-uid* 1))
+    uid))
+
+(define *template-uid* 5000)  ; 1548 in initial system as of 1/22/94
+
+(define (template-uid) *template-uid*)
+(define (set-template-uid! uid) (set! *template-uid* uid))
+
+
+
+; These variables really ought to be dynamically scoped, not global.
+; Fix this some day.
+
+(define debug-flag-names '(names maps files source tabulate table))
+
+(define type/debug-flags
+  (make-record-type 'debug-flags debug-flag-names))
+
+(define make-debug-flags
+  (record-constructor type/debug-flags debug-flag-names))
+
+(define $debug-flags
+  (make-fluid (make-debug-flags #t	;proc names
+				#f	;env maps
+				#f	;no file names
+				#f	;no cont source
+				#f	;no tabulate
+				(make-table))))
+
+(define (debug-flag-accessor name)
+  (let ((access (record-accessor type/debug-flags name)))
+    (lambda () (access (fluid $debug-flags)))))
+
+(define (debug-flag-modifier name)
+  (let ((modify (record-modifier type/debug-flags name)))
+    (lambda (new) (modify (fluid $debug-flags) new))))
+
+(define keep-source-code?      (debug-flag-accessor 'source))
+(define keep-environment-maps? (debug-flag-accessor 'maps))
+(define keep-procedure-names?  (debug-flag-accessor 'names))
+(define keep-file-names?       (debug-flag-accessor 'files))
+(define tabulate-debug-data?   (debug-flag-accessor 'tabulate))
+(define debug-data-table       (debug-flag-accessor 'table))
+
+
+; Kludge for static linker.
+
+(define (with-fresh-compiler-state template-uid-origin thunk)
+  (let-fluid $debug-flags (make-debug-flags #t ;proc names
+					    #f ;env maps
+					    #f ;no file names
+					    #f ;no cont source
+					    #t ;tabulate       ***
+					    (make-table))
+    (lambda ()
+      (saving-and-restoring (lambda () *template-uid*)
+			    (lambda (s) (set! *template-uid* s))
+			    template-uid-origin
+			    thunk))))
+
+(define (saving-and-restoring fetch store! other thunk)
+  (let ((swap (lambda ()
+		(let ((temp (fetch)))
+		  (store! other)
+		  (set! other temp)))))
+    (dynamic-wind swap thunk swap)))
+
+; --------------------
+; Debug-data stuff
+
+; "Info" means either a debug data record or an integer index into a
+; table of same.  An "info" is stored in a reserved place in every
+; template.
+
+(define (debug-data->info debug-data)
+  (make-immutable! debug-data)
+  (if (tabulate-debug-data?)
+      (begin (note-debug-data! debug-data)
+	     (debug-data-uid debug-data))
+      debug-data))
+
+(define (get-debug-data info)		;info->debug-data
+  (cond ((debug-data? info) info)
+	((integer? info)
+	 (table-ref (debug-data-table) info))
+	(else #f)))
+
+(define (note-debug-data! dd)
+  (table-set! (debug-data-table) (debug-data-uid dd) dd))
+
+
+(define (new-debug-data name parent pc-in-parent)
+  (make-debug-data (new-template-uid) name parent pc-in-parent '() '()))
diff --git a/scheme/bcomp/syntax.scm b/scheme/bcomp/syntax.scm
new file mode 100644
index 0000000..56bf027
--- /dev/null
+++ b/scheme/bcomp/syntax.scm
@@ -0,0 +1,628 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Macro expansion.
+
+;----------------
+; Scanning for definitions.
+;
+; Returns a list of forms expanded to the point needed to distinguish
+; definitions from other forms.  Definitions and syntax definitions are
+; added to ENV.
+
+(define (scan-forms forms env)
+  (let loop ((forms forms) (expanded '()))
+    (if (null? forms)
+	(reverse expanded)
+	(let ((form (expand-head (car forms) env))
+	      (more-forms (cdr forms)))
+	  (cond ((define? form)
+		 (loop more-forms
+		       (cons (scan-define form env) expanded)))
+		((define-syntax? form)
+		 (loop more-forms
+		       (append (scan-define-syntax form env)
+			       expanded)))
+		((begin? form)
+		 (loop (append (cdr form) more-forms)
+		       expanded))
+		(else
+		 (loop more-forms (cons form expanded))))))))
+
+(define (expand-scanned-form form env)
+  (if (define? form)
+      (expand-define form env)
+      (expand form env)))
+
+(define (scan-define form env)
+  (let ((new-form (destructure-define form)))
+    (if new-form
+	 (begin
+	   (environment-define! env (cadr new-form) usual-variable-type)
+	   new-form)
+	 (syntax-error "ill-formed definition" form))))
+
+(define (expand-define form env)
+  (make-node operator/define
+	     (list (car form)
+		   (expand (cadr form) env)
+		   (expand (caddr form) env))))
+
+(define (scan-define-syntax form env)
+  (if (and (or (this-long? form 3)
+	       (this-long? form 4))  ; may have name list for reifier
+	   (name? (cadr form)))
+      (let ((name (cadr form))
+	    (source (caddr form))
+	    (package (extract-package-from-environment env)))
+	(environment-define! env
+			     name
+			     syntax-type
+			     (process-syntax (if (null? (cdddr form))
+						 source
+						 `(cons ,source ',(cadddr form)))
+					     env
+					     name
+					     package))
+	'())
+      `(,(syntax-error "ill-formed syntax definition" form))))
+
+; This is used by the ,expand command.
+
+(define (expand-form form env)
+  (let loop ((forms (list form)) (expanded '()))
+    (if (null? forms)
+	(if (= (length expanded) 1)
+	    (car expanded)
+	    (make-node operator/begin (cons 'begin (reverse expanded))))
+	(let ((form (expand-head (car forms) env))
+	      (more-forms (cdr forms)))
+	  (cond ((define? form)
+		 (loop more-forms
+		       (cons (expand-define form env) expanded)))
+		((define-syntax? form)
+		 (loop more-forms
+		       (cons (make-node operator/define-syntax
+					(list (car form)
+					      (expand (cadr form) env)
+					      (make-node operator/quote
+							 `',(caddr form))))
+			     expanded)))
+		((begin? form)
+		 (loop (append (cdr form) more-forms)
+		       expanded))
+		(else
+		 (loop more-forms
+		       (cons (expand form env) expanded))))))))
+
+;----------------
+; Looking for definitions.
+; This expands the form until it reaches a name, a form whose car is an
+; operator, a form whose car is unknown, or a literal.
+
+(define (expand-head form env)
+  (cond ((node? form)
+	 (if (and (name-node? form)
+		  (not (node-ref form 'binding)))
+	     (expand-name (node-form form) env)
+	     form))
+	((name? form)
+	 (expand-name form env))
+        ((pair? form)
+	 (let ((op (expand-head (car form) env)))
+	   (if (and (node? op)
+		    (name-node? op))
+	       (let ((probe (node-ref op 'binding)))
+		 (if (binding? probe)
+		     (let ((s (binding-static probe)))
+		       (cond ((and (transform? s)
+				   (eq? (binding-type probe) syntax-type))
+			      (expand-macro-application
+			        s (cons op (cdr form)) env expand-head))
+			     ((and (operator? s)
+				   (eq? s operator/structure-ref))
+			      (expand-structure-ref form env expand-head))
+			     (else
+			      (cons op (cdr form)))))
+		     (cons op (cdr form))))
+	       (cons op (cdr form)))))
+	(else
+	 form)))
+
+; Returns a DEFINE of the form (define <id> <value>).  This handles the following
+; kinds of defines:
+;  (define <id> <value>)
+;  (define <id>)		        ; value is unassigned
+;  (define (<id> . <formals>) <value>)  ; value is a lambda
+; The return value is #f if any syntax error is found.
+
+(define (destructure-define form)
+  (if (at-least-this-long? form 2)
+      (let ((pat (cadr form))
+	    (operator (car form)))
+	(cond ((pair? pat)
+	       (if (and (names? (cdr pat))
+			(not (null? (cddr form))))
+		   `(,operator ,(car pat)
+			       (,operator/lambda ,(cdr pat)
+						 . ,(cddr form)))
+		   #f))
+	      ((null? (cddr form))
+	       `(,operator ,pat (,operator/unassigned)))
+	      ((null? (cdddr form))
+	       `(,operator ,pat ,(caddr form)))
+	      (else
+	       #f)))
+      #f))
+
+(define (make-operator-predicate operator-id)
+  (let ((operator (get-operator operator-id syntax-type)))
+    (lambda (form)
+      (and (pair? form)
+	   (eq? operator
+		(static-value (car form)))))))
+
+(define define?        (make-operator-predicate 'define))
+(define begin?         (make-operator-predicate 'begin))
+(define define-syntax? (make-operator-predicate 'define-syntax))
+
+(define (static-value form)
+  (if (and (node? form)
+	   (name-node? form))
+      (let ((probe (node-ref form 'binding)))
+	(if (binding? probe)
+	    (binding-static probe)
+	    #f))
+      #f))
+
+; --------------------
+; The horror of internal defines
+
+; This returns a single node, either a LETREC, if there are internal definitions,
+; or a BEGIN if there aren't any.
+
+(define (expand-body body env)
+  (if (null? (cdr body))  ;++
+      (expand (car body) env)
+      (call-with-values
+       (lambda ()
+	 (scan-body-forms body env '()))
+       (lambda (defs exps env)
+	 (if (null? defs)
+	     (make-node operator/begin (cons 'begin (expand-list exps env)))
+	     (expand-letrec (map car (reverse defs))
+			    (map cdr (reverse defs))
+			    exps
+			    env))))))
+
+; Walk through FORMS looking for definitions.  ENV is the current environment,
+; DEFS a list of definitions found so far.
+;
+; Returns three values: a list of (define <name> <value>) lists, a list of
+; remaining forms, and the environment to use for expanding all of the above.
+
+(define (scan-body-forms forms env defs)
+  (if (null? forms)
+      (values defs '() env)
+      (let ((form (expand-head (car forms) env))
+	    (more-forms (cdr forms)))
+	(cond ((define? form)
+	       (let ((new-form (destructure-define form)))
+		 (if new-form
+		     (let* ((name (cadr new-form))
+			    (node (make-node operator/name name)))
+		       (scan-body-forms more-forms
+					(bind1 name node env)
+					(cons (cons node
+						    (caddr new-form))
+					      defs)))
+		     (values defs
+			     (cons (syntax-error "ill-formed definition" form)
+				   more-forms)
+			     env))))
+	      ((begin? form)
+	       (call-with-values
+		(lambda ()
+		  (scan-body-forms (cdr form)
+				   env
+				   defs))
+		(lambda (new-defs exps env)
+		  (cond ((null? exps)
+			 (scan-body-forms more-forms env new-defs))
+			((eq? new-defs defs)
+			 (values defs (append exps more-forms) env))
+			(else
+			 (body-lossage forms env))))))
+	      (else
+	       (values defs (cons form more-forms) env))))))
+
+(define (body-lossage node env)
+  (syntax-error "definitions and expressions intermixed"
+		(schemify node env)))
+
+;--------------------
+; Expands all macros in FORM and returns a node.
+
+(define (expand form env)
+  (cond ((node? form)
+	 (if (and (name-node? form)
+		  (not (node-ref form 'binding)))
+	     (expand-name (node-form form) env)
+	     form))
+	((name? form)
+	 (expand-name form env))
+        ((pair? form)
+	 (if (operator? (car form))
+	     (expand-operator-form (car form) (car form) form env)
+	     (let ((op-node (expand (car form) env)))
+	       (if (name-node? op-node)
+		   (let ((probe (node-ref op-node 'binding)))
+		     (if (binding? probe)
+			 (let ((s (binding-static probe)))
+			   (cond ((operator? s)
+				  (expand-operator-form s op-node form env))
+				 ((and (transform? s)
+				       (eq? (binding-type probe) syntax-type))
+				  ;; Non-syntax transforms get done later
+				  (expand-macro-application
+				   s (cons op-node (cdr form)) env expand))
+				 (else
+				  (expand-call op-node form env))))
+			 (expand-call op-node form env)))
+		   (expand-call op-node form env)))))
+	((literal? form)
+	 (expand-literal form))
+	;; ((qualified? form) ...)
+	(else
+	 (expand (syntax-error "invalid expression" form) env))))
+
+(define (expand-list exps env)
+  (map (lambda (exp)
+	 (expand exp env))
+       exps))
+
+(define (expand-literal exp)
+  (make-node operator/literal (make-immutable! exp)))
+
+(define (expand-call proc-node exp env)
+  (if (list? exp)
+      (make-node operator/call
+		 (cons proc-node (expand-list (cdr exp) env)))
+      (expand (syntax-error "invalid expression" exp) env)))
+
+; An environment is a procedure that takes a name and returns one of
+; the following:
+;
+;  1. A binding record.
+;  2. A pair (<binding-record> . <path>)
+;  3. A node, which is taken to be a substitution for the name.
+;     Or, for lexically bound variables, this is just a name node.
+;  4. #f, for unbound variables
+;
+; In case 1, EXPAND caches the binding as the node's BINDING property.
+; In case 2, it simply returns the node.
+
+(define (expand-name name env)
+  (let ((binding (lookup env name)))
+    (if (node? binding)
+	binding
+	(let ((node (make-node operator/name name)))
+	  (node-set! node 'binding (or binding 'unbound))
+	  node))))
+
+; Expand a macro.  EXPAND may either be expand or expand-head.
+
+(define (expand-macro-application transform form env-of-use expand)
+  (call-with-values
+   (lambda ()
+     (maybe-apply-macro-transform transform
+				  form
+				  (node-form (car form))
+				  env-of-use))
+   (lambda (new-form new-env)
+     (if (eq? new-form form)
+	 (expand (syntax-error "use of macro doesn't match definition"
+			       (cons (schemify (car form) env-of-use)
+				     (desyntaxify (cdr form))))
+		 env-of-use)
+	 (expand new-form new-env)))))
+
+;--------------------
+; Specialist classifiers for particular operators
+
+(define (expand-operator-form op op-node form env)
+  ((operator-table-ref expanders (operator-uid op))
+   op op-node form env))
+
+(define expanders
+  (make-operator-table (lambda (op op-node form env)
+			 (if (let ((nargs (operator-nargs op)))
+			       (or (not nargs)
+				   (and (list? (cdr form))
+					(= nargs (length (cdr form))))))
+			     (make-node op
+					(cons op-node
+					      (expand-list (cdr form) env)))
+			     (expand-call op-node form env)))))
+
+(define (define-expander name proc)
+  (operator-define! expanders name syntax-type proc))
+
+; Definitions are not expressions.
+
+(define-expander 'define
+  (lambda (op op-node exp env)
+    (expand (syntax-error "definition in expression context" exp) env)))
+
+; Remove generated names from quotations.
+
+(define-expander 'quote
+  (lambda (op op-node exp env)
+    (if (this-long? exp 2)
+	(make-node op (list op (desyntaxify (cadr exp))))
+	(expand (syntax-error "invalid expression" exp) env))))
+
+; Don't evaluate, but don't remove generated names either.  This is
+; used when writing macro-defining macros.  Once we have avoided the
+; use of DESYNTAXIFY it is safe to replace this with regular QUOTE.
+
+(define-expander 'code-quote
+  (lambda (op op-node exp env)
+    (if (this-long? exp 2)
+	(make-node operator/quote (list op (cadr exp)))
+	(expand (syntax-error "invalid expression" exp) env))))
+
+; Convert one-armed IF to two-armed IF.
+
+(define-expander 'if
+  (lambda (op op-node exp env)
+    (cond ((this-long? exp 3)
+	   (make-node op
+		      (cons op
+			    (expand-list (append (cdr exp)
+						 (list (unspecific-node)))
+					 env))))
+	  ((this-long? exp 4)
+	   (make-node op
+		      (cons op (expand-list (cdr exp) env))))
+	  (else
+	   (expand (syntax-error "invalid expression" exp) env)))))
+
+(define (unspecific-node)
+  (make-node operator/unspecific '(unspecific)))
+
+; For the module system:
+
+(define-expander 'structure-ref
+  (lambda (op op-node form env)
+    (expand-structure-ref form env expand)))
+
+; This is also called by EXPAND-HEAD, which passes in a different expander.
+
+(define (expand-structure-ref form env expander)
+  (let ((struct-node (expand (cadr form) env))
+	(lose (lambda ()
+		(expand (syntax-error "invalid structure reference" form)
+			env))))
+    (if (and (this-long? form 3)
+	     (name? (caddr form))
+	     (name-node? struct-node))
+	(let ((b (node-ref struct-node 'binding)))
+	  (if (and (binding? b)
+		   (binding-static b)) ; (structure? ...)
+	      (expand (generate-name (desyntaxify (caddr form))
+				     (binding-static b)
+				     (node-form struct-node))
+		      env)
+	      (lose)))
+	(lose))))
+
+; Scheme 48 internal special form principally for use by the
+; DEFINE-STRUCTURES macro.
+
+(define-expander '%file-name%
+  (lambda (op op-node form env)
+    (make-node operator/quote `',(source-file-name env))))
+
+; Checking the syntax of others special forms
+
+(define-expander 'lambda
+  (lambda (op op-node exp env)
+    (if (and (at-least-this-long? exp 3)
+	     (names? (cadr exp)))
+	(expand-lambda (cadr exp) (cddr exp) env)
+	(expand (syntax-error "invalid expression" exp) env))))
+
+(define (expand-lambda names body env)
+  (call-with-values
+    (lambda ()
+      (bind-names names env))
+    (lambda (names env)
+      (make-node operator/lambda
+		 (list 'lambda names (expand-body body env))))))
+
+(define (bind-names names env)
+  (let loop ((names names) (nodes '()) (out-names '()))
+    (cond ((null? names)
+	   (values (reverse nodes)
+		   (bind out-names nodes env)))
+	  ((name? names)
+	   (let ((last (make-node operator/name names)))
+	     (values (append (reverse nodes) last)
+		     (bind (cons names out-names) (cons last nodes) env))))
+	  (else
+	   (let ((node (make-node operator/name (car names))))
+	     (loop (cdr names) (cons node nodes) (cons (car names) out-names)))))))
+
+(define (names? l)
+  (or (null? l)
+      (name? l)
+      (and (pair? l)
+	   (name? (car l))
+	   (names? (cdr l)))))
+
+(define-expander 'set!
+  (lambda (op op-node exp env)
+    (if (and (this-long? exp 3)
+	     (name? (cadr exp)))
+	(make-node op (cons op (expand-list (cdr exp) env)))
+	(expand (syntax-error "invalid expression" exp) env))))
+
+(define-expander 'letrec
+  (lambda (op op-node exp env)
+    (if (and (at-least-this-long? exp 3)
+	     (specs? (cadr exp)))
+	(let ((specs (cadr exp))
+	      (body (cddr exp)))
+	  (let* ((names (map (lambda (spec)
+			       (make-node operator/name (car spec)))
+			     specs))
+		 (env (bind (map car specs) names env)))
+	    (expand-letrec names (map cadr specs) body env)))
+	(expand (syntax-error "invalid expression" exp) env))))
+
+(define (expand-letrec names values body env)
+  (let* ((new-specs (map (lambda (name value)
+			   (list name
+				 (expand value env)))
+			 names
+			 values)))
+    (make-node operator/letrec
+	       (list 'letrec new-specs (expand-body body env)))))
+
+(define-expander 'loophole
+  (lambda (op op-node exp env)
+    (if (this-long? exp 3)
+	(make-node op (list op
+			    (sexp->type (desyntaxify (cadr exp)) #t)
+			    (expand (caddr exp) env)))
+	(expand (syntax-error "invalid expression" exp) env))))
+
+(define-expander 'let-syntax
+  (lambda (op op-node exp env)
+    (if (and (at-least-this-long? exp 3)
+	     (specs? (cadr exp)))
+	(let ((specs (cadr exp)))
+	  (expand-body (cddr exp)
+		       (bind (map car specs)
+			     (map (lambda (spec)
+				    (make-binding syntax-type
+						  (list 'let-syntax)
+						  (process-syntax (cadr spec)
+								  env
+								  (car spec)
+								  env)))
+				  specs)
+			     env)))
+	(expand (syntax-error "invalid expression" exp) env))))
+
+(define-expander 'letrec-syntax
+  (lambda (op op-node exp env)
+    (if (and (at-least-this-long? exp 3)
+	     (specs? (cadr exp)))
+	(let ((specs (cadr exp)))
+	  (expand-body
+	    (cddr exp)
+	    (bindrec (map car specs)
+		     (lambda (new-env)
+		       (map (lambda (spec)
+			      (make-binding syntax-type
+					    (list 'letrec-syntax)
+					    (process-syntax (cadr spec)
+							    new-env
+							    (car spec)
+							    new-env)))
+			    specs))
+		     env)))
+	(expand (syntax-error "invalid expression" exp) env))))
+    
+(define (process-syntax form env name env-or-package)
+  (let ((eval+env (force (environment-macro-eval env))))
+    (make-transform ((car eval+env) form (cdr eval+env))
+		    env-or-package
+		    syntax-type
+		    form
+		    name)))
+
+; This just looks up the names that the LAP code will want and replaces them
+; with the appropriate node.
+;
+; (lap <id> (<free name> ...) <instruction> ...)
+
+(define-expander 'lap
+  (lambda (op op-node exp env)
+    (if (and (at-least-this-long? exp 4)
+	     (name? (cdr exp))
+	     (every name? (caddr exp)))
+	(make-node op `(,op
+			,(desyntaxify (cadr exp))
+			,(map (lambda (name)
+				(expand-name (cadr exp) env))
+			      (caddr exp))
+			. ,(cdddr exp)))
+	(expand (syntax-error "invalid expression" exp) env))))
+
+; --------------------
+; Syntax checking utilities
+
+(define (this-long? l n)
+  (cond ((null? l)
+	 (= n 0))
+	((pair? l)
+	 (this-long? (cdr l) (- n 1)))
+	(else
+	 #f)))
+
+(define (at-least-this-long? l n)
+  (cond ((null? l)
+	 (<= n 0))
+	((pair? l)
+	 (at-least-this-long? (cdr l) (- n 1)))
+	(else
+	 #f)))
+
+(define (specs? x)
+  (or (null? x)
+      (and (pair? x)
+	   (let ((s (car x)))
+	     (and (pair? s)
+		  (name? (car s))
+		  (pair? (cdr s))
+		  (null? (cddr s))))
+	   (specs? (cdr x)))))
+
+; --------------------
+; Utilities
+
+(define (literal? exp)
+  (or (number? exp) (char? exp) (string? exp) (boolean? exp)))
+
+(define (syntax? d)
+  (cond ((operator? d)
+	 (eq? (operator-type d) syntax-type))
+	((transform? d)
+	 (eq? (transform-type d) syntax-type))
+	(else #f)))
+
+;----------------
+; Node predicates and operators.
+
+(define begin-node? (node-predicate 'begin syntax-type))
+(define call-node? (node-predicate 'call 'internal))
+(define name-node? (node-predicate 'name 'leaf))
+
+(define operator/literal (get-operator 'literal 'leaf))
+(define operator/quote (get-operator 'quote syntax-type))
+(define operator/call (get-operator 'call 'internal))
+(define operator/name (get-operator 'name 'leaf))
+(define operator/unspecific (get-operator 'unspecific (proc () unspecific-type)))
+(define operator/unassigned (get-operator 'unassigned (proc () value-type)))
+(define operator/lambda (get-operator 'lambda syntax-type))
+(define operator/begin (get-operator 'begin syntax-type))
+(define operator/letrec (get-operator 'letrec syntax-type))
+(define operator/define (get-operator 'define syntax-type))
+(define operator/define-syntax (get-operator 'define-syntax syntax-type))
+(define operator/primitive-procedure
+  (get-operator 'primitive-procedure syntax-type))
+(define operator/structure-ref (get-operator 'structure-ref syntax-type))
+
+
diff --git a/scheme/bcomp/thingie.scm b/scheme/bcomp/thingie.scm
new file mode 100644
index 0000000..981d87c
--- /dev/null
+++ b/scheme/bcomp/thingie.scm
@@ -0,0 +1,16 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; A thingie (placecard?) is used to hold a spot for a location that is to be
+; found later.  The compiler sticks them in templates and the module system
+; later replaces them with locations.
+;
+; We can't use (BEGIN ...) for this trivial package because it is loaded
+; by flatload, which can't handle them.
+
+(define-record-type thingie :thingie
+  (make-thingie binding name want-type)
+  thingie?
+  (binding thingie-binding)
+  (name thingie-name)
+  (want-type thingie-want-type))
+
diff --git a/scheme/bcomp/transform.scm b/scheme/bcomp/transform.scm
new file mode 100644
index 0000000..a688206
--- /dev/null
+++ b/scheme/bcomp/transform.scm
@@ -0,0 +1,108 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Transforms
+
+; A transform represents a source-to-source rewrite rule: either a
+; macro or an in-line procedure.
+
+(define-record-type transform :transform
+  (really-make-transform xformer env type aux-names source id)
+  transform?
+  (xformer   transform-procedure)
+  (env	     transform-env)
+  (type	     transform-type)
+  (aux-names transform-aux-names) ;for reification
+  (source    transform-source)    ;for reification
+  (id	     transform-id))
+
+(define (make-transform thing env type source id)
+  (let ((type (if (or (pair? type)
+		      (symbol? type))
+		  (sexp->type type #t)
+		  type)))
+    (make-immutable!
+     (if (pair? thing)
+	 (really-make-transform (car thing) env type (cdr thing) source id)
+	 (really-make-transform thing       env type #f          source id)))))
+
+(define-record-discloser :transform
+  (lambda (m) (list 'transform (transform-id m))))
+
+(define (maybe-apply-macro-transform transform exp parent-name env-of-use)
+  (let* ((token (cons #f #f))
+	 (new-env (bind-aliases token transform env-of-use))
+	 (rename (make-name-generator (transform-env transform)
+				      token
+				      parent-name))
+	 (compare (make-keyword-comparator new-env)))
+    (values ((transform-procedure transform) exp rename compare)
+	    new-env)))
+
+(define (apply-inline-transform transform exp parent-name)
+  (let* ((env (transform-env transform))
+	 (rename (make-name-generator env (cons #f #f) parent-name)))
+    ((transform-procedure transform) exp env rename)))
+
+; Two keywords are the same if:
+;  - they really are the same
+;  - neither one is bound and they have the same symbol in the source
+;  - they are bound to the same denotation (macro or location or ...)
+
+(define (make-keyword-comparator environment)
+  (lambda (name1 name2)
+    (or (eqv? name1 name2)
+	(and (name? name1)	; why might they not be names?
+	     (name? name2)
+	     (let ((v1 (lookup environment name1))
+		   (v2 (lookup environment name2)))
+	       (if v1
+		   (and v2 (same-denotation? v1 v2))
+		   (and (not v2)
+			(equal? (name->source-name name1)
+				(name->source-name name2)))))))))
+
+; Get the name that appeared in the source.
+
+(define (name->source-name name)
+  (if (generated? name)
+      (generated-symbol name)
+      name))
+				       
+; The env-of-definition for macros defined at top-level is a package,
+; and the package system will take care of looking up the generated
+; names.
+
+(define (bind-aliases token transform env-of-use)
+  (let ((env-of-definition (transform-env transform)))
+    (if (procedure? env-of-definition)
+	(lambda (name)
+	  (if (and (generated? name)
+		   (eq? (generated-token name)
+			token))
+	      (lookup env-of-definition (generated-symbol name))
+	      (lookup env-of-use name)))
+	env-of-use)))
+
+; Generate names for bindings reached in ENV reached via PARENT-NAME.
+; The names are cached to preserve identity if they are bound.  TOKEN
+; is used to identify names made by this generator.
+
+(define (make-name-generator env token parent-name)
+  (let ((alist '()))			;list of (symbol . generated)
+    (lambda (symbol)
+      (if (symbol? symbol)
+	  (let ((probe (assq symbol alist)))
+	    (if probe
+		(cdr probe)
+		(let ((new-name (make-generated symbol token env parent-name)))
+		  (set! alist (cons (cons symbol new-name)
+				    alist))
+		  new-name)))
+	  (error "non-symbol argument to rename procedure"
+		 symbol parent-name)))))
+
+;----------------
+; We break an abstraction here to avoid a circular module dependency.
+
+(define (lookup cenv name)
+  (cenv name))
\ No newline at end of file
diff --git a/scheme/bcomp/type.scm b/scheme/bcomp/type.scm
new file mode 100644
index 0000000..a2b59b2
--- /dev/null
+++ b/scheme/bcomp/type.scm
@@ -0,0 +1,53 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; The types.
+
+(define :syntax
+  (loophole :type syntax-type))
+
+(define :values
+  (loophole :type any-values-type))
+
+(define :arguments
+  (loophole :type any-arguments-type))
+
+(define :value
+  (loophole :type value-type))
+
+(define procedure
+  (loophole (proc (:type :type) :type)
+	    (lambda (dom cod) (procedure-type dom cod #t))))
+
+; Use the definitions of PROC and SOME-VALUES from the meta-types module
+
+
+; Various base types
+
+(define :boolean     (loophole :type boolean-type))
+(define :char        (loophole :type char-type))
+(define :null        (loophole :type null-type))
+(define :unspecific  (loophole :type unspecific-type))
+
+(define :number      (loophole :type number-type))
+(define :complex     (loophole :type complex-type))
+(define :real	     (loophole :type real-type))
+(define :rational    (loophole :type rational-type))
+(define :integer     (loophole :type integer-type))
+(define :exact-integer (loophole :type exact-integer-type))
+
+(define :pair        (loophole :type pair-type))
+(define :string      (loophole :type string-type))
+(define :symbol      (loophole :type symbol-type))
+(define :vector	     (loophole :type vector-type))
+(define :procedure   (loophole :type any-procedure-type))
+
+; Temporary
+(define :input-port :value)
+(define :output-port :value)
+
+(define :error       (loophole :type error-type))
+(define :escape	     (loophole :type escape-type))
+
+(define :structure   (loophole :type structure-type))
+(define :type	     (loophole :type value-type))
diff --git a/scheme/bcomp/usual.scm b/scheme/bcomp/usual.scm
new file mode 100644
index 0000000..db673b3
--- /dev/null
+++ b/scheme/bcomp/usual.scm
@@ -0,0 +1,302 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; This is file usual.scm.
+
+;;;; Macro expanders for the standard macros
+
+(define the-usual-transforms (make-table))
+
+(define (define-usual-macro name proc aux-names)
+  (table-set! the-usual-transforms
+	      name
+	      (cons proc aux-names)))
+
+(define (usual-transform name)
+  (or (table-ref the-usual-transforms name)
+      (call-error "no such transform" usual-transform name)))
+
+; Ordinarily we would write #f instead of ,#f below.  However, it is
+; useful (although decreasingly so) to be able compile Scheme 48
+; images using a Scheme system that does not distinguish #f from ().
+; In this case, the cross-compiler treats the expression #f (= ()) as
+; boolean false, and any () (= #f) in a quoted constant as the empty
+; list.  If we were to write `(if ... #f) then this would be seen in
+; the *target* system as `(if ... ()), which would be a syntax error.
+
+(define-usual-macro 'and
+  (lambda (exp r c)
+    (let ((conjuncts (cdr exp)))
+      (cond ((null? conjuncts) `#t)
+	    ((null? (cdr conjuncts)) (car conjuncts))
+	    (else `(,(r 'if) ,(car conjuncts)
+		       (,(r 'and) ,@(cdr conjuncts))
+		       ,#f)))))
+  '(if and))
+
+; Tortuously crafted so as to avoid the need for an (unspecific)
+; procedure.  Unspecific values come from IF forms.
+
+(define-usual-macro 'cond
+  (lambda (exp r c)
+    (let ((clauses (cdr exp)))
+      (if (or (null? clauses)
+	      (not (every list? clauses)))
+	  exp
+	  (car (let recur ((clauses clauses))
+		 (if (null? clauses)
+		     '()
+		     (list
+		      (let ((clause (car clauses))
+			    (more (recur (cdr clauses))))
+			(cond ((c (car clause) (r 'else))
+			       ;; (if (not (null? more)) ...error...)
+			       `(,(r 'begin) ,@(cdr clause)))
+			      ((null? (cdr clause))
+			       `(,(r 'or) ,(car clause)
+					  ,@more))
+			      ((c (cadr clause) (r '=>))
+			       (let ((temp (r 'temp)))
+				 (if (null? (cddr clause))
+				     exp
+				     `(,(r 'let)
+				       ((,temp ,(car clause)))
+				       (,(r 'if) ,temp
+						 (,(caddr clause) ,temp)
+						 ,@more)))))
+			      (else
+			       `(,(r 'if) ,(car clause)
+					  (,(r 'begin) ,@(cdr clause))
+					  ,@more)))))))))))
+  '(or cond begin let if begin))
+
+(define-usual-macro 'do
+  (lambda (exp r c)
+    (if (and (pair? (cdr exp))
+	     (pair? (cddr exp)))
+	(let ((specs (cadr exp))
+	      (end (caddr exp))
+	      (body (cdddr exp))
+	      (%loop (r 'loop))
+	      (%letrec (r 'letrec))
+	      (%lambda (r 'lambda))
+	      (%cond (r 'cond)))
+	  (if (and (list? specs)
+		   (every do-spec? specs)
+		   (list? end))
+	      `(,%letrec ((,%loop
+			   (,%lambda ,(map car specs)
+				     (,%cond ,end
+					     (else ,@body
+						   (,%loop
+						    ,@(map (lambda (spec)
+							     (if (null? (cddr spec))
+								 (car spec)
+								 (caddr spec)))
+							   specs)))))))
+			 (,%loop ,@(map cadr specs)))
+	      exp))
+	exp))
+  '(letrec lambda cond))
+
+(define (do-spec? s)
+  (and (pair? s)
+       (name? (car s))
+       (pair? (cdr s))
+       (let ((rest (cddr s)))
+	 (or (null? rest)
+	     (and (pair? rest)
+		  (null? (cdr rest)))))))
+
+(define-usual-macro 'let
+  (lambda (exp r c)
+    (if (pair? (cdr exp))
+	(let ((specs (cadr exp))
+	      (body (cddr exp))
+	      (%lambda (r 'lambda)))
+	  (if (name? specs)
+	      (let ((tag specs)
+		    (specs (car body))
+		    (body (cdr body))
+		    (%letrec (r 'letrec)))
+		(if (specs? specs)
+		    `((,%letrec ((,tag (,%lambda ,(map car specs) ,@body)))
+				,tag)
+		      ,@(map cadr specs))
+		    exp))
+	      (if (specs? specs)
+		  `((,%lambda ,(map car specs) ,@body)
+		    ,@(map cadr specs))
+		  exp)))
+	exp))
+  '(lambda letrec))
+
+(define-usual-macro 'let*
+  (lambda (exp r c)
+    (if (pair? (cdr exp))
+	(let ((specs (cadr exp))
+	      (body (cddr exp)))
+	  (if (specs? specs)
+	      (if (or (null? specs)
+		      (null? (cdr specs)))
+		  `(,(r 'let) ,specs ,@body)
+		  `(,(r 'let) (,(car specs))
+			      (,(r 'let*) ,(cdr specs) ,@body)))
+	      exp))
+	exp))
+  '(let let*))
+
+(define (specs? x)
+  (or (null? x)
+      (and (pair? x)
+	   (let ((s (car x)))
+	     (and (pair? s)
+		  (name? (car s))
+		  (pair? (cdr s))
+		  (null? (cddr s))))
+	   (specs? (cdr x)))))
+
+(define-usual-macro 'or
+  (lambda (exp r c)
+    (let ((disjuncts (cdr exp)))
+      (cond ((null? disjuncts)
+	     #f)  ;not '#f
+	    ((not (pair? disjuncts))
+	     exp)
+	    ((null? (cdr disjuncts))
+	     (car disjuncts))
+	    (else
+	     (let ((temp (r 'temp)))
+	       `(,(r 'let) ((,temp ,(car disjuncts)))
+		  (,(r 'if) ,temp
+			    ,temp
+			    (,(r 'or) ,@(cdr disjuncts)))))))))
+  '(let if or))
+
+; CASE needs auxiliary MEMV.
+
+(define-usual-macro 'case
+  (lambda (exp r c)
+    (if (and (list? (cdr exp))
+	     (every (lambda (clause)
+		      (case-clause? clause c (r 'else)))
+		    (cddr exp)))
+	(let ((key (cadr exp))
+	      (clauses (cddr exp))
+	      (temp (r 'temp))
+	      (%eqv? (r 'eqv?))
+	      (%eq? (r 'eq?))     ;+++ hack for symbols
+	      (%memv (r 'memv))
+	      (%quote (r 'quote))
+	      (%else (r 'else)))
+	  `(,(r 'let)
+	    ((,temp ,key))
+	    (,(r 'cond)
+	     ,@(map (lambda (clause)
+		      `(,(cond ((c (car clause) %else)
+				(car clause))
+			       ((null? (car clause))
+				#f)
+			       ((null? (cdar clause)) ;+++
+				`(,(if (symbol? (caar clauses)) %eq? %eqv?)
+				    ,temp
+				    (,%quote ,(caar clause))))
+			       (else
+				`(,%memv ,temp (,%quote ,(car clause)))))
+			,@(cdr clause)))
+		    clauses))))
+	exp))
+  '(let cond eqv? eq? memv quote))
+
+(define (case-clause? c compare %else)
+  (and (list? c)
+       (let ((head (car c)))
+	 (or (null? head)
+	     (compare head %else)
+	     (list? head)))))
+
+; Quasiquote
+
+(define-usual-macro 'quasiquote
+  (lambda (exp r c)
+
+    (define %quote (r 'quote))
+    (define %quasiquote (r 'quasiquote))
+    (define %unquote (r 'unquote))
+    (define %unquote-splicing (r 'unquote-splicing))
+    (define %append (r 'append))
+    (define %cons (r 'cons))
+    (define %list->vector (r 'list->vector))
+
+    (define (expand-quasiquote x level)
+      (descend-quasiquote x level finalize-quasiquote))
+
+    (define (finalize-quasiquote mode arg)
+      (cond ((eq? mode 'quote) `(,%quote ,arg))
+	    ((eq? mode 'unquote) arg)
+	    ((eq? mode 'unquote-splicing)
+	     (syntax-error ",@ in invalid context" arg))
+	    (else `(,mode ,@arg))))
+
+    (define (descend-quasiquote x level return)
+      (cond ((vector? x)
+	     (descend-quasiquote-vector x level return))
+	    ((not (pair? x))
+	     (return 'quote x))
+	    ((interesting-to-quasiquote? x %quasiquote)
+	     (descend-quasiquote-pair x (+ level 1) return))
+	    ((interesting-to-quasiquote? x %unquote)
+	     (cond ((= level 0)
+		    (return 'unquote (cadr x)))
+		   (else
+		    (descend-quasiquote-pair x (- level 1) return))))
+	    ((interesting-to-quasiquote? x %unquote-splicing)
+	     (cond ((= level 0)
+		    (return 'unquote-splicing (cadr x)))
+		   (else
+		    (descend-quasiquote-pair x (- level 1) return))))
+	    (else
+	     (descend-quasiquote-pair x level return))))
+
+    (define (descend-quasiquote-pair x level return)
+      (descend-quasiquote (car x) level
+	(lambda (car-mode car-arg)
+	  (descend-quasiquote (cdr x) level
+	    (lambda (cdr-mode cdr-arg)
+	      (cond ((and (eq? car-mode 'quote) (eq? cdr-mode 'quote))
+		     (return 'quote x))
+		    ((eq? car-mode 'unquote-splicing)
+		     ;; (,@mumble ...)
+		     (cond ((and (eq? cdr-mode 'quote) (null? cdr-arg))
+			    (return 'unquote
+				    car-arg))
+			   (else
+			    (return %append
+				    (list car-arg (finalize-quasiquote
+						     cdr-mode cdr-arg))))))
+		    (else
+		     (return %cons
+			     (list (finalize-quasiquote car-mode car-arg)
+				   (finalize-quasiquote cdr-mode cdr-arg))))))))))
+
+    (define (descend-quasiquote-vector x level return)
+      (descend-quasiquote (vector->list x) level
+	(lambda (mode arg)
+	  (case mode
+	    ((quote) (return 'quote x))
+	    (else (return %list->vector
+			  (list (finalize-quasiquote mode arg))))))))
+
+    (define (interesting-to-quasiquote? x marker)
+      (and (pair? x) (c (car x) marker)))
+
+    (if (and (pair? (cdr exp))
+	     (null? (cddr exp)))
+	(expand-quasiquote (cadr exp) 0)
+	exp))
+  '(append cons list->vector quasiquote unquote unquote-splicing))
+
+
+;(define (tst e)
+;  (let ((probe (usual-transform (car e))))
+;    ((car probe) e (lambda (x) x) eq?)))
diff --git a/scheme/bcomp/var-util.scm b/scheme/bcomp/var-util.scm
new file mode 100644
index 0000000..f009697
--- /dev/null
+++ b/scheme/bcomp/var-util.scm
@@ -0,0 +1,21 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+(define (number-of-required-args formals)
+  (do ((l formals (cdr l))
+       (i 0 (+ i 1)))
+      ((not (pair? l)) i)))
+    
+(define (n-ary? formals)
+  (cond ((null? formals) #f)
+	((pair? formals) (n-ary? (cdr formals)))
+	(else #t)))
+    
+(define (normalize-formals formals)
+  (cond ((null? formals)
+	 '())
+	((pair? formals)
+	 (cons (car formals)
+	       (normalize-formals (cdr formals))))
+	(else
+	 (list formals))))
+
diff --git a/scheme/big/array.scm b/scheme/big/array.scm
new file mode 100644
index 0000000..3480796
--- /dev/null
+++ b/scheme/big/array.scm
@@ -0,0 +1,319 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+; copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
+
+
+; (make-array <initial-value> <bound1> ...)
+; (array-shape <array>)
+; (array-ref <array> <index1> ...)
+; (array-set! <array> <value> <index1> ...)
+; (make-shared-array <array> <linear-map> <bound1> ...)
+; (copy-array <array>)
+; (array->vector <array>)
+; (array <bounds> . <elements>)
+;
+; All arrays are zero based.
+;
+; The <linear-map> argument to MAKE-SHARED-ARRAY is a linear function
+; that maps indices into the shared array into a list of indices into
+; the original array.  The array returned by MAKE-SHARED-ARRAY shares
+; storage with the original array.
+;
+; (array-ref (make-shared-array a f i1 i2 ... iN) j1 j2 ... jM)
+;   <==>
+; (apply array-ref a (f j1 j2 ... jM))
+;
+; ARRAY->VECTOR returns a vector containing the elements of an array
+; in row-major order.
+
+; An array consists of a vector containing the bounds of the array,
+; a vector containing the elements of the array, and a linear map
+; expressed as a vector of coefficients and one constant.
+; If the map is #(c1 c2 ... cN C0) then the index into the vector of
+; elements for (array-ref a i1 i2 ... iN) is
+; (+ (* i1 c1) (* i2 c2) ... (* iN cN) C0).
+
+; Interface due to Alan Bawden (except for requiring zero-based arrays)
+; Implementation by Richard Kelsey.
+
+(define-record-type array :array
+  (really-make-array bounds map elements)
+  array?
+  (bounds   array-bounds)       ; vector of array bounds
+  (map      array-map)          ; vector of coefficients + one constant
+  (elements array-elements))    ; vector of actual elements
+
+(define-record-discloser :array
+  (lambda (array)
+    (cons 'array (array-shape array))))
+
+(define (array-shape array)
+  (vector->list (array-bounds array)))
+
+; Calculate the index into an array's element vector that corresponds to
+; INDICES.  MAP is the array's linear map.
+
+(define (fast-array-index indices map)
+  (let ((size (- (vector-length map) 1)))
+    (do ((i 0 (+ i 1))
+	 (j (vector-ref map size)
+	    (+ j (* (vector-ref indices i)
+		    (vector-ref map i)))))
+	((>= i size) j))))
+
+; The same thing with bounds checking added.
+
+(define (array-index array indices)
+  (let ((bounds       (array-bounds array))
+	(coefficients (array-map array)))
+    (let loop ((is indices)
+	       (i 0)
+	       (index (vector-ref coefficients (vector-length bounds))))
+      (cond ((null? is)
+	     (if (= i (vector-length bounds))
+		 index
+		 (error "wrong number of array indices" array indices)))
+	    ((>= i (vector-length bounds))
+	     (error "wrong number of array indices" array indices))
+	    (else
+	     (let ((j (car is)))
+	       (if (and (>= j 0)
+			(< j (vector-ref bounds i)))
+		   (loop (cdr is)
+			 (+ i 1)
+			 (+ index (* j (vector-ref coefficients i))))
+		   (error "array index out of range" array indices))))))))
+
+(define (array-ref array . indices)
+  (vector-ref (array-elements array) (array-index array indices)))
+
+(define (array-set! array value . indices)
+  (vector-set! (array-elements array) (array-index array indices) value))
+
+; This is mostly error checking.
+
+(define (make-array initial bound1 . bounds)
+  (let* ((all-bounds (cons bound1 bounds))
+	 (bounds (make-vector (length all-bounds)))
+	 (size (do ((bs all-bounds (cdr bs))
+		    (i 0 (+ i 1))
+		    (s 1 (* s (car bs))))
+		   ((null? bs) s)
+		 (let ((b (car bs)))
+		   (vector-set! bounds i b)
+		   (if (not (and (integer? b)
+				 (exact? b)
+				 (< 0 b)))
+		       (error "illegal array bounds" all-bounds))))))
+    (really-make-array bounds
+		       (bounds->map bounds)
+		       (make-vector size initial))))
+
+(define (array bounds . elts)
+  (let* ((array (apply make-array #f bounds))
+	 (elements (array-elements array))
+	 (size (vector-length elements)))
+    (if (not (= (length elts) size))
+	(error "ARRAY got the wrong number of elements" bounds elts))
+    (do ((i 0 (+ i 1))
+	 (elts elts (cdr elts)))
+	((null? elts))
+      (vector-set! elements i (car elts)))
+    array))
+
+; Determine the linear map that corresponds to a simple array with the
+; given bounds.
+
+(define (bounds->map bounds)
+  (do ((i (- (vector-length bounds) 1) (- i 1))
+       (s 1 (* s (vector-ref bounds i)))
+       (l '() (cons s l)))
+      ((< i 0)
+       (list->vector (reverse (cons 0 (reverse l)))))))
+
+; This is mostly error checking.  Two different procedures are used to
+; check that the shared array does not extend past the original.  The
+; full check does a complete check, but, because it must check every corner
+; of the shared array, it gets very slow as the number of dimensions
+; goes up.  The simple check just verifies that the all elements of
+; the shared array map to elements in the vector of the original.
+
+(define (make-shared-array array linear-map . bounds)
+  (let ((map (make-shared-array-map array linear-map bounds)))
+    (if (if (<= (length bounds) maximum-full-bounds-check)
+	    (full-array-bounds-okay? linear-map bounds (array-bounds array))
+	    (simple-array-bounds-okay? map bounds (vector-length
+						   (array-elements array))))
+	(really-make-array (list->vector bounds)
+			   map
+			   (array-elements array))
+	(error "shared array out of bounds" array linear-map bounds))))
+
+(define maximum-full-bounds-check 5)
+
+; Check that every corner of the array specified by LINEAR and NEW-BOUNDS
+; is within OLD-BOUNDS.  This checks every corner of the new array.
+
+(define (full-array-bounds-okay? linear new-bounds old-bounds)
+  (let ((old-bounds (vector->list old-bounds)))
+    (let label ((bounds (reverse new-bounds)) (args '()))
+      (if (null? bounds)
+	  (let loop ((res (apply linear args)) (bounds old-bounds))
+	    (cond ((null? res)
+		   (null? bounds))
+		  ((and (not (null? bounds))
+			(<= 0 (car res))
+			(< (car res) (car bounds)))
+		   (loop (cdr res) (cdr bounds)))
+		  (else #f)))
+	  (and (label (cdr bounds) (cons 0 args))
+	       (label (cdr bounds) (cons (- (car bounds) 1) args)))))))
+
+; Check that the maximum and minimum possible vector indices possible with
+; the given bounds and map would fit in an array of the given size.
+
+(define (simple-array-bounds-okay? map bounds size)
+  (do ((map (vector->list map) (cdr map))
+       (bounds bounds (cdr bounds))
+       (min 0 (if (> 0 (car map))
+		  (+ min (* (car map) (- (car bounds) 1)))
+		  min))
+       (max 0 (if (< 0 (car map))
+		  (+ max (* (car map) (- (car bounds) 1)))
+		  max)))
+      ((null? bounds)
+       (and (>= 0 (+ min (car map)))
+	    (< size (+ max (car map)))))))
+
+; Determine the coefficients and constant of the composition of
+; LINEAR-MAP and the linear map of ARRAY.  BOUNDS is used only to
+; determine the rank of LINEAR-MAP's domain.
+;
+; The coefficients are determined by applying first LINEAR-MAP and then
+; ARRAY's map to the vectors (1 0 0 ... 0), (0 1 0 ... 0), ..., (0 ... 0 1).
+; Applying them to (0 ... 0) gives the constant of the composition.
+
+(define (make-shared-array-map array linear-map bounds)
+  (let* ((zero (map (lambda (ignore) 0) bounds))
+	 (do-vector (lambda (v)
+		      (or (apply-map array (apply linear-map v))
+			  (error "bad linear map for shared array"
+				 linear-map array bounds))))
+	 (base (do-vector zero)))
+    (let loop ((bs bounds) (ces '()) (unit (cons 1 (cdr zero))))
+      (if (null? bs)
+	  (list->vector (reverse (cons base ces)))
+	  (loop (cdr bs)
+		(cons (- (do-vector unit) base) ces)
+		(rotate unit))))))
+
+; Apply ARRAY's linear map to the indices in the list VALUES and
+; return the resulting vector index.  #F is returned if VALUES is not
+; the correct length or if any of its elements are out of range.
+
+(define (apply-map array values)
+  (let ((map (array-map array))
+	(bounds (array-bounds array)))
+    (let loop ((values values)
+	       (i 0)
+	       (index (vector-ref map (vector-length bounds))))
+      (cond ((null? values)
+	     (if (= i (vector-length bounds))
+		 index
+		 #f))
+	    ((>= i (vector-length bounds))
+	     #f)
+	    (else
+	     (let ((j (car values)))
+	       (if (and (>= j 0)
+			(< j (vector-ref bounds i)))
+		   (loop (cdr values)
+			 (+ i 1)
+			 (+ index (* j (vector-ref map i))))
+		   #f)))))))
+
+; Return LIST with its last element moved to the front.
+
+(define (rotate list)
+  (let ((l (reverse list)))
+    (cons (car l) (reverse (cdr l)))))
+
+; Copy an array, shrinking the vector if this is subarray that does not
+; use all of the original array's elements.
+
+(define (copy-array array)
+  (really-make-array (array-bounds array)
+		     (bounds->map (array-bounds array))
+		     (array->vector array)))
+
+; Make a new vector and copy the elements into it.  If ARRAY's map is
+; the simple map for its bounds, then the elements are already in the
+; appropriate order and we can just copy the element vector.
+
+(define (array->vector array)
+  (let* ((size (array-element-count array))
+	 (new (make-vector size)))
+    (if (and (= size (vector-length (array-elements array)))
+	     (equal? (array-map array) (bounds->map (array-bounds array))))
+	(copy-vector (array-elements array) new)
+	(copy-elements array new))
+    new))
+
+(define (array-element-count array)
+  (let ((bounds (array-bounds array)))
+    (do ((i 0 (+ i 1))
+	 (s 1 (* s (vector-ref bounds i))))
+	((>= i (vector-length bounds))
+	 s))))
+  
+(define (copy-vector from to)
+  (do ((i (- (vector-length to) 1) (- i 1)))
+      ((< i 0))
+    (vector-set! to i (vector-ref from i))))
+
+; Copy the elements of ARRAY into the vector TO.  The copying is done one
+; row at a time.  POSN is a vector containing the index of the row that
+; we are currently copying.  After the row is copied, POSN is updated so
+; that the next row can be copied.  A little more cleverness would make
+; this faster by replacing the call to FAST-ARRAY-INDEX with some simple
+; arithmetic on J.
+
+(define (copy-elements array to)
+  (let ((bounds   (array-bounds array))
+	(elements (array-elements array))
+	(map      (array-map array)))
+    (let* ((size (vector-length bounds))
+	   (posn (make-vector size 0))
+	   (step-size (vector-ref bounds (- size 1)))
+	   (delta (vector-ref map (- size 1))))
+      (let loop ((i 0))
+	(do ((i2 i (+ i2 1))
+	     (j (fast-array-index posn map) (+ j delta)))
+	    ((>= i2 (+ i step-size)))
+	  (vector-set! to i2 (vector-ref elements j)))
+	(cond ((< (+ i step-size) (vector-length to))
+	       (let loop2 ((k (- size 2)))
+		 (cond ((= (+ (vector-ref posn k) 1) (vector-ref bounds k))
+			(vector-set! posn k 0)
+			(loop2 (- k 1)))
+		       (else
+			(vector-set! posn k (+ 1 (vector-ref posn k))))))
+	       (loop (+ i step-size))))))))
+
+; Testing.
+; (define a1 (make-array 0 4 5))
+;  0  1  2  3
+;  4  5  6  7
+;  8  9 10 11
+; 12 13 14 15
+; 16 17 18 19
+; (make-shared-array-map a1 (lambda (x) (list x x)) '(3))
+; 0 5 10, #(5 0)
+; (make-shared-array-map a1 (lambda (x) (list 2 (- 4 x))) '(3))
+; 18 14 10 #(-4 18)
+; (make-shared-array-map a1 (lambda (x y) (list (+ x 1) y)) '(2 4))
+;  1  2
+;  5  6
+;  9 10
+; 13 14
+; #(1 4 1)
+
diff --git a/scheme/big/big-util.scm b/scheme/big/big-util.scm
new file mode 100644
index 0000000..c7ee265
--- /dev/null
+++ b/scheme/big/big-util.scm
@@ -0,0 +1,204 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+(define (concatenate-symbol . stuff)
+  (string->symbol
+   (apply string-append
+	  (map (lambda (x)
+		 (cond ((string? x) x)
+		       ((symbol? x) (symbol->string x))
+		       ((number? x) (number->string x))
+		       (else
+			(error "cannot coerce ~S to a string" x))))
+	       stuff))))
+
+(define (error format-string . args)
+  (if #t       ; work around a bug in the type system
+      ((structure-ref signals error)
+       (apply format (cons #f (cons format-string args)))))
+  )
+
+(define (breakpoint format-string . args)
+  ((structure-ref debugging breakpoint) 
+   (apply format (cons #f (cons format-string args)))))
+
+(define (atom? x)
+  (not (pair? x)))
+
+(define (neq? x y)
+  (not (eq? x y)))
+
+(define (n= x y)
+  (not (= x y)))
+
+(define (identity x) x)
+
+(define (no-op x) x)    ; guaranteed not to be in-lined
+
+(define (null-list? x)
+  (cond ((null? x) #t)
+	((pair? x) #f)
+	(else
+	 (error "null-list? got a non-list" x))))
+
+(define (reverse! l)
+  (cond ((or (null? l)
+	     (null? (cdr l)))
+	 l)
+	(else
+	 (let ((rest (cdr l)))
+	   (set-cdr! l '())
+	   (let loop ((l1 l) (l2 rest))
+	     (cond ((null? l2)
+		    l1)
+		   (else
+		    (let ((rest (cdr l2)))
+		      (set-cdr! l2 l1)
+		      (loop l2 rest)))))))))
+
+(define (memq? x l)
+  (let loop ((l l))
+    (cond ((null? l)       #f)
+	  ((eq? x (car l)) #t)
+	  (else            (loop (cdr l))))))
+
+(define (first pred list)
+  (let loop ((list list))
+    (cond ((null? list)
+	   #f)
+          ((pred (car list))
+	   (car list))
+          (else
+	   (loop (cdr list))))))
+
+(define any first)  ; ANY? need not search in order, but it does anyway
+
+(define (any? proc list)
+  (let loop ((list list))
+    (cond ((null? list)
+	   #f)
+          ((proc (car list))
+	   #t)
+          (else
+	   (loop (cdr list))))))
+
+(define (every? pred list)
+  (let loop ((list list))
+    (cond ((null? list)
+	   #t)
+          ((pred (car list))
+	   (loop (cdr list)))
+          (else
+	   #f))))
+
+(define (filter pred l)
+  (let loop ((l l) (r '()))
+    (cond ((null? l)
+	   (reverse r))
+          ((pred (car l))
+	   (loop (cdr l) (cons (car l) r)))
+          (else
+	   (loop (cdr l) r)))))
+
+(define (filter! pred list)
+  (let filter! ((list list))
+    (cond ((null-list? list)
+	   '())
+          ((pred (car list))
+	   (set-cdr! list (filter! (cdr list))) list)
+          (else
+	   (filter! (cdr list))))))
+
+(define (filter-map f l)
+  (let loop ((l l) (r '()))
+    (cond ((null? l)
+	   (reverse r))
+          ((f (car l))
+           => (lambda (x)
+                (loop (cdr l) (cons x r))))
+          (else
+	   (loop (cdr l) r)))))
+
+(define (remove-duplicates list)
+  (do ((list list (cdr list))
+       (res  '()  (if (memq? (car list) res)
+                      res
+                      (cons (car list) res))))
+      ((null-list? list)
+       res)))
+
+(define (partition-list pred l)
+  (let loop ((l l) (yes '()) (no '()))
+    (cond ((null? l)
+           (values (reverse yes) (reverse no)))
+          ((pred (car l))
+           (loop (cdr l) (cons (car l) yes) no))
+          (else
+           (loop (cdr l) yes (cons (car l) no))))))
+
+(define (partition-list! pred l)
+  (let loop ((l l) (yes '()) (no '()))
+    (cond ((null? l)
+           (values (reverse! yes) (reverse! no)))
+          ((pred (car l))
+	   (let ((rest (cdr l)))
+	     (set-cdr! l yes)
+	     (loop rest l no)))
+          (else
+	   (let ((rest (cdr l)))
+	     (set-cdr! l no)
+	     (loop rest yes l))))))
+
+(define (delq! object list)
+  (let loop ((list list))
+    (cond ((null? list)
+	   '())
+	  ((eq? object (car list))
+	   (loop (cdr list)))
+	  (else
+	   (let loop ((next (cdr list)) (prev list))
+	     (cond ((null? next)
+		    list)
+		   ((eq? (car next) object)
+		    (set-cdr! prev (cdr next))
+		    (loop (cdr next) prev))
+		   (else
+		    (loop (cdr next) next))))))))
+
+(define (delq thing list)
+  (delete (lambda (x) (eq? x thing)) list))
+
+(define (delete pred in-list)
+  (let loop ((list in-list) (res '()))
+    (cond ((null? list)
+	   in-list)
+	  ((pred (car list))
+	   (append-reverse! res (delete pred (cdr list))))
+	  (else
+	   (loop (cdr list) (cons (car list) res))))))
+
+(define (append-reverse! l1 l2)
+  (let loop ((list l1) (res l2))
+    (cond ((null? list)
+	   res)
+	  (else
+	   (let ((next (cdr list)))
+	     (set-cdr! list res)
+	     (loop next list))))))
+
+; Copying strings.
+
+(define (copy-string string)
+  (let* ((length (string-length string))
+	 (new (make-string length #\?)))
+    ((structure-ref primitives copy-bytes!) string 0 new 0 length)
+    new))
+
+(define (string->immutable-string string)
+  (if (immutable? string)
+      string
+      (let ((copy (copy-string string)))
+	(make-immutable! copy)
+	copy)))
+
+
+
diff --git a/scheme/big/bigbit.scm b/scheme/big/bigbit.scm
new file mode 100644
index 0000000..0269f25
--- /dev/null
+++ b/scheme/big/bigbit.scm
@@ -0,0 +1,207 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Bitwise logical operators on bignums.
+
+
+(define-opcode-extension bitwise-not &bitwise-not)
+(define-opcode-extension bitwise-and &bitwise-and)
+(define-opcode-extension bitwise-ior &bitwise-ior)
+(define-opcode-extension bitwise-xor &bitwise-xor)
+(define-opcode-extension arithmetic-shift &arithmetic-shift)
+
+
+(define (integer-bitwise-not m)
+  ;; (integer+ (integer-negate m) -1)
+  (integer- -1 m))
+
+(define (integer-bitwise-and m n)
+  (if (or (integer= 0 m) (integer= 0 n))
+      0
+      (integer-bitwise-op bitwise-and m n)))
+
+(define (integer-bitwise-ior m n)
+  (cond ((integer= 0 m) n)
+	((integer= 0 n) m)
+	(else
+	 (integer-bitwise-op bitwise-ior m n))))
+
+(define (integer-bitwise-xor m n)
+  (cond ((integer= 0 m) n)
+	((integer= 0 n) m)
+	(else
+	 (integer-bitwise-op bitwise-xor m n))))
+
+(define (integer-bitwise-op op m n)
+  (let ((m (integer->bignum m))
+	(n (integer->bignum n)))
+    (let ((finish (lambda (sign-bit mag-op)
+		    (let ((mag (mag-op op
+				       (bignum-magnitude m)
+				       (bignum-magnitude n))))
+		      (make-integer (if (= 0 sign-bit) 1 -1)
+				    (if (= 0 sign-bit)
+					mag
+					(negate-magnitude mag)))))))
+      (if (>= (bignum-sign m) 0)
+	  (if (>= (bignum-sign n) 0)
+	      (finish (op 0 0) magnitude-bitwise-binop-pos-pos)
+	      (finish (op 0 1) magnitude-bitwise-binop-pos-neg))
+	  (if (>= (bignum-sign n) 0)
+	      (finish (op 0 1) magnitude-bitwise-binop-neg-pos)
+	      (finish (op 1 1) magnitude-bitwise-binop-neg-neg))))))
+
+(define radix-mask (- radix 1))
+
+(define (magnitude-bitwise-binop-pos-pos op m n)
+  (let recur ((m m) (n n))
+    (if (and (zero-magnitude? m) (zero-magnitude? n))
+	m
+	(adjoin-digit (bitwise-and (op (low-digit m) (low-digit n)) radix-mask)
+		      (recur (high-digits m) (high-digits n))))))
+
+; Same as the above, except that one magnitude is that of a negative number.
+
+(define (magnitude-bitwise-binop-neg-pos op m n)
+  (magnitude-bitwise-binop-pos-neg op n m))
+
+(define (magnitude-bitwise-binop-pos-neg op m n)
+  (let recur ((m m) (n n) (carry 1))
+    (if (and (zero-magnitude? n) (zero-magnitude? m))
+	(integer->magnitude (op 0 carry))
+	(call-with-values
+	 (lambda ()
+	   (negate-low-digit n carry))
+	 (lambda (n-digit carry)
+	   (adjoin-digit (op (low-digit m) n-digit)
+			 (recur (high-digits m)
+				(high-digits n)
+				carry)))))))
+
+; Now both M and N are magnitudes of negative numbers.
+
+(define (magnitude-bitwise-binop-neg-neg op m n)
+  (let recur ((m m) (n n) (m-carry 1) (n-carry 1))
+    (if (and (zero-magnitude? n) (zero-magnitude? m))
+	(integer->magnitude (op m-carry n-carry))
+	(call-with-values
+	 (lambda ()
+	   (negate-low-digit m m-carry))
+	 (lambda (m-digit m-carry)
+	   (call-with-values
+	    (lambda ()
+	      (negate-low-digit n n-carry))
+	    (lambda (n-digit n-carry)
+	      (adjoin-digit (op m-digit n-digit)
+			    (recur (high-digits m)
+				   (high-digits n)
+				   m-carry
+				   n-carry)))))))))
+
+(define (negate-low-digit m carry)
+  (let ((m (+ (bitwise-and (bitwise-not (low-digit m))
+			   radix-mask)
+	      carry)))
+    (if (>= m radix)
+	(values (- m radix) 1)
+	(values m 0))))
+
+(define (negate-magnitude m)
+  (let recur ((m m) (carry 1))
+    (if (zero-magnitude? m)
+	(integer->magnitude carry)
+	(call-with-values
+	 (lambda ()
+	   (negate-low-digit m carry))
+	 (lambda (next carry)
+	   (adjoin-digit next
+			 (recur (high-digits m) carry)))))))
+
+; arithmetic-shift
+
+(define (integer-arithmetic-shift m n)
+  (let ((m (integer->bignum m)))
+    (make-integer (bignum-sign m)
+		  (cond ((> n 0)
+			 (shift-left-magnitude (bignum-magnitude m) n))
+			((= 1 (bignum-sign m))
+			 (shift-right-pos-magnitude (bignum-magnitude m) n))
+			(else
+			 (shift-right-neg-magnitude (bignum-magnitude m) n))))))
+
+(define (shift-left-magnitude mag n)
+  (if (< n log-radix)
+      (let ((mask (- (arithmetic-shift 1 (- log-radix n)) 1)))
+	(let recur ((mag mag)
+		    (low 0))
+	  (if (zero-magnitude? mag)
+	      (adjoin-digit low zero-magnitude)
+	      ;; Split the low digit into left and right parts, and shift
+	      (let ((left (arithmetic-shift (low-digit mag)
+					    (- n log-radix))) ;shift right
+		    (right (arithmetic-shift (bitwise-and (low-digit mag) mask)
+					     n)))
+		(adjoin-digit (bitwise-ior low right)
+			      (recur (high-digits mag)
+				     left))))))
+      (adjoin-digit 0 (shift-left-magnitude mag (- n log-radix)))))
+
+(define (shift-right-pos-magnitude mag n)
+  (if (> n (- 0 log-radix))
+      (let ((mask (- (arithmetic-shift 1 (- 0 n)) 1)))
+	(let recur ((mag mag))
+	  (let ((low (low-digit mag))
+		(high (high-digits mag)))
+	    (adjoin-digit
+	     (bitwise-ior (arithmetic-shift low n)
+			  (arithmetic-shift (bitwise-and mask (low-digit high))
+					    (+ n log-radix)))
+	     (if (zero-magnitude? high)
+		 zero-magnitude
+		 (recur high))))))
+      (shift-right-pos-magnitude (high-digits mag) (+ n log-radix))))
+      
+(define (shift-right-neg-magnitude mag n)
+  (negate-magnitude
+   (let digit-recur ((mag mag) (n n) (carry 1))
+     (call-with-values
+      (lambda ()
+	(negate-low-digit mag carry))
+      (lambda (digits carry)
+	(if (<= n (- 0 log-radix))
+	    (digit-recur (high-digits mag) (+ n log-radix) carry)
+	    (let ((mask (- (arithmetic-shift 1 (- 0 n)) 1)))
+	      (let recur ((mag mag) (low digits) (carry carry))
+		(let ((high-digits (high-digits mag)))
+		  (call-with-values
+		   (lambda ()
+		     (negate-low-digit high-digits carry))
+		   (lambda (high carry)
+		     (adjoin-digit
+		      (bitwise-ior (arithmetic-shift low n)
+				   (arithmetic-shift (bitwise-and mask high)
+						     (+ n log-radix)))
+		      (if (zero-magnitude? high-digits)
+			  (integer->magnitude carry)
+			  (recur high-digits high carry))))))))))))))
+
+;(define (tst)
+;  (let* ((m (random))
+;         (n (bitwise-and m 63))
+;         (m1 (integer-arithmetic-shift
+;              (integer-arithmetic-shift m n)
+;              (- 0 n))))
+;    (list n m m1 (= m m1))))
+;(define random (make-random 17))
+
+
+(define-method &bitwise-not ((n :integer)) (integer-bitwise-not n))
+
+(define-method &bitwise-and ((n1 :exact-integer) (n2 :exact-integer))
+  (integer-bitwise-and n1 n2))
+(define-method &bitwise-ior ((n1 :exact-integer) (n2 :exact-integer))
+  (integer-bitwise-ior n1 n2))
+(define-method &bitwise-xor ((n1 :exact-integer) (n2 :exact-integer))
+  (integer-bitwise-xor n1 n2))
+
+(define-method &arithmetic-shift ((n1 :exact-integer) (n2 :exact-integer))
+  (integer-arithmetic-shift n1 n2))
diff --git a/scheme/big/callback.scm b/scheme/big/callback.scm
new file mode 100644
index 0000000..3831ac7
--- /dev/null
+++ b/scheme/big/callback.scm
@@ -0,0 +1,293 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This code, along with C code in c/external.c, handles the interaction between
+; callbacks from external code to Scheme functions and uses of continuations in
+; Scheme.  The problem is that Scheme 48 uses multiple continuations while
+; operating with only one process stack.
+;
+; Suppose we have Scheme procedures s1 and s2 and C procedure c1 such that
+; s1 calls c1 and c1 calls s2.  There are two trampoline functions that are
+; used to do this.  The VM uses s48_external_call to call c1 and c1 uses
+; s48_call_scheme to start the VM running s2.  While in s2 the process stack will
+; look like this:
+;
+;  <C frame for VM running s2>
+;  <C frame for s48_call_scheme>
+;  <C frame for c1>
+;  <C frame for s48_external_call>
+;  <C frame for VM running s1>
+;  <base>
+;
+; The C code in c/external.scm keeps a record of the portions of the process
+; stack that are running external code.  Each of these stack portions has an
+; s48_external_call frame at the base and an s48_call_scheme frame at the top.
+; The stack is represented as linked list of records, called `stack-block's,
+; each of which contains the following values:
+;    free?       ; true if this frame is no longer needed
+;    unwind      ; the longjmp target used to skip over this frame
+;    proc-name   ; the name of the procedure this block is executing
+;    placeholder ; either #f or a placeholder, see the section on threads below
+;    next        ; the next stack-block below this one
+; These are Scheme records and are traced by the GC.
+
+(define-record-type stack-block :stack-block
+  (stack-blocks-are-made-from-c)
+  stack-block?
+  (free? stack-block-free? set-stack-block-free?!)
+  (unwind stack-block-unwind)
+  (proc-name stack-block-proc-name)
+  (placeholder stack-block-placeholder set-stack-block-placeholder!)
+  (next stack-block-next))
+
+; Stack-blocks are made from C, so we need to export the type.
+
+(define-exported-binding "s48-stack-block-type" :stack-block)
+
+; There is no need to keep track of the VM frames.  These are all interchangable
+; because 1) the VM's state is kept in top-level variables and 2) we have
+; arranged it so that the relevent VM opcodes, call-external-value and
+; return-from-callback, are all the same length and are always immediately
+; followed by a return instruction.  s48_call_scheme can safely overwrite the
+; template and code-pointer registers in the VM as they always point to a
+; one-byte instruction followed by a return instruction.  When the VM returns
+; from the callback, via a return-from-callback instruction, that too is a
+; one-byte instruction followed by a return instruction.  The VM can proceed,
+; happily ignorant of all this fooling around.
+;
+; On entry, s48_external_call saves a longjump target.  This is used when
+; raising exceptions from with the external code and for unwinding the process
+; stack.  Each invocation of s48_call_scheme creates a new stack-block, saving
+; within it the longjump target of the corresponding s48_external_call.  `Free?'
+; and `placeholder' are initially false and `next' points to existing list of
+; stack-blocks.
+;
+; When a callback returns to s48_call_scheme, the corresponding block is popped
+; off the list of stack-blocks.
+;
+; So far so good, and if that were all that happened there would be no need for
+; all this mechanism.  There are two problems: call/cc and threads.  Call/cc is
+; simpler to deal with.  We have downward continuations in C, as implemented
+; by longjmp(), so we simply limit continuations that cross callbacks to being
+; downwards only.  We also need to arrange for any jumped-over stack portions
+; to be popped off of the stack.
+;
+; The popping off is handled by s48_external_call.  Just before returning to the
+; VM it checks to see if the top stack-block is free.  If so, it loops through
+; the list of stack-blocks to find the first non-free stack portion.  A longjump
+; is performed to the target in the last free block, removing any unneeded frames
+; from the stack.
+;
+; s48_call_scheme starts the VM running the following CALLBACK procedure.  The
+; arguments are BLOCK, the stack-block just created for this callback, and
+; the procedure and arguments for the actual callback.  It prevents jumps back
+; into the callback and frees BLOCK if a throw out occurs.
+;
+; We disable interrupts to ensure that nothing intervenes between setting DONE?
+; and returning from the callback.  BLOCK is then either freed or returned to,
+; but not both or neither.  RETURN-FROM-CALLBACK reenables interrupts.
+
+(define (callback block proc . args)
+  (let ((done? #f))
+    (return-from-callback block
+			  (dynamic-wind
+			   (lambda ()
+			     (if done?
+				 (error "attempt to throw into a callback"
+					(cons proc args))))
+			   (lambda ()
+			     (let ((result (apply proc args)))
+			       (disable-interrupts!)
+			       (set! done? #t)
+			       result))
+			   (lambda ()
+			     (if (not done?)
+				 (begin
+				   (set! done? #t)
+				   (set-stack-block-free?! block #t)
+				   (clear-stack-top!))))))))
+
+(define-exported-binding "s48-callback" callback)
+
+; CLEAR-STACK-TOP! is an empty C procedure.  When it returns, s48_external_call
+; will automatically clear any free frames off of the stack.
+
+(import-lambda-definition clear-stack-top! () "s48_clear_stack_top")
+
+; Dealing with threads.
+;
+; The difficulty here is that each stack-block belongs to some thread.  Thread A
+; can call a C procedures which calls back into Scheme.  At that point a context
+; switch occurs and we start running thread B, which promptly does the same
+; calls.  THe process stack then looks like this:
+; 
+;  <C frame for VM running B1>
+;  <C frame for s48_call_scheme>
+;  <C frame for B's c code>
+;  <C frame for s48_external_call>
+;  <C frame for VM running A1 and then B0>
+;  <C frame for s48_call_scheme>
+;  <C frame for A's c code>
+;  <C frame for s48_external_call>
+;  <C frame for VM running A0>
+;  <base>
+;
+; At this point A cannot return from its callback before B does, because B's
+; portion of the process stack is above A's.  If A does try to return it must
+; block until it again is at the top of the stack.
+;
+; This is handled by s48_call_scheme, which checks to see if the stack-block
+; being returned to is at the top of the stack.  If not, it does a second
+; callback to DELAY-CALLBACK-RETURN, defined below, with the same stack-block.
+; DELAY-CALLBACK-RETURN creates a placeholder, puts it in the stack-block, and
+; then blocks on it.  When the placeholder gets a value the procedure attempts
+; another return-from-callback.
+;
+; This is called with interrupts disabled, as we need to avoid having BLOCK
+; reach the top of the stack before the placeholder is installed.
+
+(define (delay-callback-return block value)
+  (let ((placeholder (make-placeholder)))
+    (set-stack-block-placeholder! block placeholder)
+    (enable-interrupts!)
+    (placeholder-value placeholder)
+    value))
+
+(define-exported-binding "s48-delay-callback-return" delay-callback-return)
+
+; Finally, s48_external_call looks to see if the top stack-block has a
+; placeholder.  If it does, it raises an exception instead of doing a normal
+; return.  The exception handler sets the placeholder's value, allowing the
+; blocked thread to continue.  The handler then returns the external call's
+; value to its own thread, or, if the callback-return-uncovered is piggybacked
+; on another exception, we raise that exception.
+;
+; Because of the all of the games played above, the callback-return-uncovered
+; exception may appear to have come from either the call-external-value, or
+; return-from-callback opcodes.
+
+(define uncovered-return-handler
+  (lambda (opcode reason . args)
+    (if (= reason (enum exception callback-return-uncovered))
+	(call-with-values
+	 (lambda ()
+	   (if (= 2 (length args))
+	       (values (car args)
+		       (cadr args)
+		       #f)
+	       (let ((args (reverse args)))
+		 (values (car args)
+			 (cadr args)
+			 (reverse (cddr args))))))
+	 (lambda (block return-value exception-args)
+	   (let ((placeholder (stack-block-placeholder block)))
+	     (set-stack-block-placeholder! block #f)
+	     (placeholder-set! placeholder #t)
+	     (if exception-args
+		 (apply signal-exception opcode return-value exception-args)
+		 return-value))))
+	(apply signal-exception opcode reason args))))
+
+(define (block-depth block)
+  (if block
+      (+ 1 (block-depth (stack-block-next block)))
+      0))
+
+(for-each (lambda (opcode)
+	    (define-exception-handler opcode uncovered-return-handler))
+	  (list (enum op call-external-value)
+		(enum op return-from-callback)))
+
+;----------------
+; Utility for the common case of calling an imported binding.
+
+(define (call-imported-binding proc . args)
+  (if (and (shared-binding? proc)
+	   (shared-binding-is-import? proc))
+      (let ((value (shared-binding-ref proc)))
+	(if (byte-vector? value)
+	    (apply call-external-value
+		   value
+		   (shared-binding-name proc)
+		   args)
+	    (apply call-error "bad procedure" call-imported-binding proc args)))
+      (apply call-error "bad procedure" call-imported-binding proc args)))
+
+;----------------
+; Helper functions for converting between C longs and Scheme bignums.
+;
+; HIGH and LOW are the two sixteen-bit halves of the negative magnitude of
+; the number.  The negative magnitude is used to avoid problems with two's
+; complement's asymmetry.
+
+(define (long-to-bignum positive? high low)
+  (let ((magnitude (+ (arithmetic-shift high 16)
+                      low)))
+    (if positive?
+        (- magnitude)
+        magnitude)))
+
+; Same again, except that we break the number into the sign and the two halves.
+
+(define (bignum-to-long n)
+  (if (integer? n)
+      (let ((m (abs n)))
+        (vector (>= n 0)
+	        (arithmetic-shift m -16)
+	        (bitwise-and m sixteen-candles)))
+      #f))
+
+(define sixteen-candles (- (arithmetic-shift 1 16) 1))
+
+(define-exported-binding "s48-long-to-bignum" long-to-bignum)
+(define-exported-binding "s48-bignum-to-long" bignum-to-long)
+
+;----------------
+; Testing
+;
+; `s48_trampoline' is a C routine that calls its Scheme argument with between
+; zero and three arguments.  The arguments are 100, 200, and 300.
+;
+;(import-lambda-definition trampoline (proc nargs)
+;                          "s48_trampoline")
+;
+;(define (foo . args)
+;  (for-each display (list "[foo " args "]"))
+;  (newline)
+;  (cons 'foo-return args))
+;
+;; This should return 1100.
+;
+;(define (test0)
+;  (trampoline (lambda ()
+;                (call-with-current-continuation
+;                  (lambda (c)
+;                    (trampoline (lambda (x)
+;                                  (c (+ x 1000)))
+;                                1))))
+;              0))
+;
+;; ,open threads locks debug-messages
+;
+;(define (test1 error?)
+;  (let ((lock (make-lock))
+;        (repl-lock (make-lock)))
+;    (obtain-lock repl-lock)
+;    (spawn (lambda ()
+;             (obtain-lock lock)
+;             (debug-message "A returned "
+;                           (trampoline (lambda ()
+;                                         (obtain-lock lock) ; we block
+;                                         'a)
+;                                       0))
+;             (release-lock repl-lock))
+;           'thread-a)
+;    (spawn (lambda ()
+;             (debug-message "B returned "
+;                           (trampoline (lambda ()
+;                                         (release-lock lock)    ; A can run
+;                                         (relinquish-timeslice) ; let A run
+;                                         (if error? #f 'b))
+;                                       0)))
+;           'thread-b)
+;    (obtain-lock repl-lock)))
diff --git a/scheme/big/compose-cont.scm b/scheme/big/compose-cont.scm
new file mode 100644
index 0000000..c4ec4cf
--- /dev/null
+++ b/scheme/big/compose-cont.scm
@@ -0,0 +1,44 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+
+
+(define (compose-continuation proc cont)
+  (primitive-cwcc
+    (lambda (k)
+      (with-continuation cont ;(if cont cont null-continuation)
+        (lambda ()
+          (proc (primitive-cwcc
+                  (lambda (k2) (with-continuation k (lambda () k2))))))))))
+
+
+; Old definition that relies on details of VM architecture:
+
+;(define null-continuation #f)
+
+;(define null-continuation (make-continuation 4 #f)) ;temp kludge
+;(continuation-set! null-continuation 1 0)
+;(continuation-set! null-continuation 2
+;                   ;; op/trap = 140
+;                   (segment-data->template (make-code-vector 1 140) #f '()))
+
+;(put 'primitive-cwcc 'scheme-indent-hook 0)
+;(put 'with-continuation 'scheme-indent-hook 1)
+
+;(define compose-continuation
+;  (let ((tem
+;         (let ((cv (make-code-vector 6 0)))
+;           (code-vector-set! cv 0 op/push) ;push return value
+;           (code-vector-set! cv 1 op/local) ;fetch procedure
+;           (code-vector-set! cv 3 1)    ;over = 1
+;           (code-vector-set! cv 4 op/call)
+;           (code-vector-set! cv 5 1)    ;one argument
+;           (segment-data->template cv 0 '()))))
+;    (lambda (proc parent-cont)
+;      (let ((cont (make-continuation 4 #f)))
+;        (continuation-set! cont 0 parent-cont)
+;        (continuation-set! cont 1 0)    ;pc
+;        (continuation-set! cont 2 tem)  ;template
+;        (continuation-set! cont 3 (vector #f proc)) ;environment
+;        cont))))
+
diff --git a/scheme/big/defrecord.scm b/scheme/big/defrecord.scm
new file mode 100644
index 0000000..221f750
--- /dev/null
+++ b/scheme/big/defrecord.scm
@@ -0,0 +1,147 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Syntax for defining record types
+
+; This knows about the implementation of records and creates the various
+; accessors, mutators, etc. directly instead of calling the procedures
+; from the record structure.  This is done to allow the optional auto-inlining
+; optimizer to inline the accessors, mutators, etc.
+
+; LOOPHOLE is used to get a little compile-time type checking (in addition to
+; the usual complete run-time checking).
+
+; (define-record-type name constructor-fields other-fields)
+
+; Constructor-arguments fields are either <name> or (<name>), the second
+; indicating a field whose value can be modified.
+; Other-fields are one of:
+;  (<name> <expression>) = modifiable field with the given value.
+;  <name>                = modifiable field with no initial value.
+
+;(define-record-type job
+;  ((thunk)
+;   (dynamic-env)
+;   number
+;   inferior-lock
+;   )
+;  ((on-queue  #f)
+;   (superior  #f)
+;   (inferiors '())
+;   (condition #f)
+;   ))
+
+(define-syntax define-record-type
+
+  (let ()
+
+    (define s->s symbol->string)
+    (define s-conc (lambda args (string->symbol (apply string-append args))))
+    (define spec-name (lambda (s) (if (pair? s) (car s) s)))
+    (define (filter pred lst)
+      (if (null? lst)
+	  '()
+	  (if (pred (car lst))
+	      (cons (car lst) (filter pred (cdr lst)))
+	      (filter pred (cdr lst)))))
+    (define (ass compare name list)
+      (cond ((null? list) #f)
+	    ((and (pair? (car list))
+		  (compare name (caar list)))
+	     (car list))
+	    (else
+	     (ass compare name (cdr list)))))
+
+    (lambda (form rename compare)
+      (let* ((name (cadr form))
+	     (arg-fields (caddr form))
+	     (other-fields (cadddr form))
+	     (init-fields (filter pair? other-fields))
+	     (args (map spec-name arg-fields))
+
+	     (field-name (lambda (field-name)
+			   (s-conc (s->s name) "-" (s->s field-name))))
+	     (set-name (lambda (field-name)
+			 (s-conc "set-" (s->s name)
+				 "-" (s->s field-name) "!")))
+	     (pred-name (s-conc (s->s name) "?"))
+	     (maker-name (s-conc (s->s name) "-maker"))
+	     (type-name (s-conc "type/" (s->s name)))
+
+	     (thing (rename 'name))
+	     (%make-record-type   (rename 'make-record-type))
+	     (%record             (rename 'record))
+	     (%define-accessors   (rename 'define-accessors))
+	     (%unspecific	  (rename 'unspecific))
+	     (%loophole		  (rename 'loophole))
+	     (%:value		  (rename ':value))
+	     (%proc		  (rename 'proc))
+	     (%define		  (rename 'define))
+	     (%let		  (rename 'let))
+	     (%lambda		  (rename 'lambda))
+	     (%begin		  (rename 'begin)))
+	`(,%begin
+	   (,%define ,type-name
+	     (,%make-record-type ',name
+				 ',(map spec-name
+					(append arg-fields other-fields))))
+	   (,%define ,maker-name
+	       (,%loophole (,%proc ,(map (lambda (x) %:value) args) ,type-name)
+		 (,%lambda ,args
+			   (,%record ,type-name
+				     ,@args
+				     . ,(map (lambda (field)
+					       (cond ((ass compare
+							   (spec-name field)
+							   other-fields)
+						      => cadr)
+						     (else
+						      `(,%unspecific))))
+					     other-fields)))))
+	   (,%define ,pred-name
+	       (,%lambda (,(rename 'x))
+		   (,(rename 'and)
+		    (,(rename 'record?) ,(rename 'x))
+		    (,(rename 'eq?) ,type-name
+				    (,(rename 'record-ref) ,(rename 'x) 0)))))
+	   (,%define-accessors ,type-name
+			       ,@(map (lambda (spec)
+					(if (pair? spec)
+					    `(,(field-name (car spec))
+					      ,(set-name (car spec)))
+					    `(,(field-name spec))))
+				      arg-fields)
+			       ,@(map (lambda (spec)
+					`(,(field-name (spec-name spec))
+					  ,(set-name (spec-name spec))))
+				      other-fields)))))))
+
+(define-syntax define-accessors
+  (lambda (e r c)
+    (let ((%define-accessor (r 'define-accessor))
+	  (%begin (r 'begin))
+	  (type (cadr e))
+	  (field-specs (cddr e)))
+      (do ((i 1 (+ i 1))
+	   (field-specs field-specs (cdr field-specs))
+	   (ds '()
+	       (cons `(,%define-accessor ,type ,i ,@(car field-specs))
+		     ds)))
+	  ((null? field-specs)
+	   `(,%begin ,@ds)))))
+  (define-accessor begin))
+
+(define-syntax define-accessor
+  (syntax-rules ()
+    ((define-accessor ?type ?index ?accessor)
+     (define ?accessor
+       (loophole (proc (?type) :value)
+		 (lambda (r)
+		   (checked-record-ref (loophole :record r) ?type ?index)))))
+    ((define-accessor ?type ?index ?accessor ?modifier)
+     (begin (define-accessor ?type ?index ?accessor)
+	    (define ?modifier
+	      (loophole (proc (?type :value) :unspecific)
+			(lambda (r new)
+			  (checked-record-set! (loophole :record r) ?type ?index new))))))
+    ((define-accessor ?type ?index)
+     (begin))))
diff --git a/scheme/big/destructure.scm b/scheme/big/destructure.scm
new file mode 100644
index 0000000..9918f84
--- /dev/null
+++ b/scheme/big/destructure.scm
@@ -0,0 +1,63 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; This is a destructuring version of LET.
+; (DESTRUCTURE ((<pattern> <expression>) ...) body ...)
+; The patterns can be:
+;   identifiers, which are bound to the corresponding part of the value
+;   lists of patterns (including dotted pairs)
+;   vectors of patterns
+;
+; Bug (?): (destructure (((a) '(1 2))) ...) works.  The code does not check
+; to see if there are more elements than the minimum number required.
+
+(define-syntax destructure
+  (lambda (form rename compare)
+    (let ((specs (cadr form))
+	  (body (cddr form))
+	  (%car (rename 'car))
+	  (%cdr (rename 'cdr))
+	  (%vref (rename 'vector-ref))
+	  (%let* (rename 'let*))
+	  (gensym (lambda (i)
+		    (rename (string->symbol
+			     (string-append "x" (number->string i))))))
+	  (atom? (lambda (x) (not (pair? x)))))
+      (letrec ((expand-pattern
+		(lambda (pattern value i)
+		  (cond ((or (not pattern) (null? pattern))
+			 '())
+			((vector? pattern)
+			 (let ((xvalue (if (atom? value)
+					   value
+					   (gensym i))))
+			   `(,@(if (eq? value xvalue) '() `((,xvalue ,value)))
+			     ,@(expand-vector pattern xvalue i))))
+			((atom? pattern)
+			 `((,pattern ,value)))
+			(else
+			 (let ((xvalue (if (atom? value)
+					   value
+					   (gensym i))))
+			   `(,@(if (eq? value xvalue) '() `((,xvalue ,value)))
+			     ,@(expand-pattern (car pattern)
+					       `(,%car ,xvalue)
+					       (+ i 1))
+			     ,@(if (null? (cdr pattern))
+ 				   '()
+				   (expand-pattern (cdr pattern)
+						   `(,%cdr ,xvalue)
+						   (+ i 1)))))))))
+	       (expand-vector
+		(lambda (vec xvalue i)
+		  (do ((j (- (vector-length vec) 1) (- j 1))
+		       (ps '() (append (expand-pattern (vector-ref vec j)
+						       `(,%vref ,xvalue ,j)
+						       (+ i 1))
+				       ps)))
+		      ((< j 0) ps)))))
+	(do ((specs specs (cdr specs))
+	     (res '() (append (expand-pattern (caar specs) (cadar specs) 0)
+			      res)))
+	    ((null? specs)
+	     `(,%let* ,res . ,body)))))))
+
diff --git a/scheme/big/dump.scm b/scheme/big/dump.scm
new file mode 100644
index 0000000..e8a7790
--- /dev/null
+++ b/scheme/big/dump.scm
@@ -0,0 +1,429 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Dump and restore
+
+; Unix has special meanings for
+;  ETX, FS, DEL, ETB, NAK, DC2, EOT, EM (or SUB?), DC3, DC1, SI, SYN,
+;  3    28  127  23   21   18   4    25     26     19   17   15  22
+; so avoid using them.
+
+(define type/null        #\n)
+(define type/true	 #\t)
+(define type/false	 #\f)
+(define type/unspecific #\u)
+(define type/pair        #\p)  ;obj1 obj2
+(define type/string	 #\s)  ;length chars
+(define type/number	 #\i)  ;#chars rep
+(define type/symbol	 #\y)  ;length chars
+(define type/char	 #\c)  ;char
+(define type/vector      #\v)  ;length objects
+(define type/template    #\a)  ;length objects
+(define type/code-vector #\k)  ;length bytes (each byte is 2 hex digits?)
+(define type/location	 #\l)  ;uid
+(define type/closure	 #\q)  ;template-info
+(define type/ellipsis	 #\e)
+(define type/random	 #\r)
+
+
+; Recursive entry
+
+(define (dump obj write-char depth)
+  (cond ((null? obj) (dump-type type/null write-char))
+	((eq? obj #t) (dump-type type/true write-char))
+	((eq? obj #f) (dump-type type/false write-char))
+	((pair? obj) (dump-pair obj write-char depth))
+	;; Template case needs to precede vector case
+	((template? obj) (dump-template obj write-char depth))
+	((vector? obj) (dump-vector obj write-char depth))
+	((symbol? obj) (dump-symbol obj write-char))
+	((number? obj) (dump-number obj write-char))
+	((string? obj) (dump-string obj write-char))
+	((char? obj) (dump-char-literal obj write-char))
+	((code-vector? obj) (dump-code-vector obj write-char))
+	((location? obj) (dump-location obj write-char))
+	((unspecific? obj) (dump-type type/unspecific write-char))
+	((closure? obj) (dump-closure obj write-char))
+	(else (dump-random obj write-char depth))))
+
+(define (restore read-char)
+  (let ((type (restore-type read-char)))
+    ((vector-ref restorers (char->ascii type)) type read-char)))
+    
+(define restorers
+  (make-vector 256 (lambda (type read-char)
+		     ;; Invalid type
+		     (error "invalid type code" type))))
+
+(define (define-restorer! type proc)
+  (vector-set! restorers (char->ascii type) proc))
+
+
+; Particular dumpers & restorers
+
+(define-restorer! type/null  (lambda (c read-char) '()))
+(define-restorer! type/false (lambda (c read-char) #f))
+(define-restorer! type/true  (lambda (c read-char) #t))
+(define-restorer! type/unspecific (lambda (c read-char) (if #f #f)))
+
+; Pairs
+
+(define (dump-pair obj write-char depth)
+  (if (= depth 0)
+      (dump-ellipsis obj write-char)
+      (let ((depth (- depth 1)))
+	(dump-type type/pair write-char)
+	(dump (car obj) write-char depth)
+	(dump (cdr obj) write-char depth))))
+
+(define-restorer! type/pair
+  (lambda (c write-char)
+    c ;ignored
+    (let ((the-car (restore write-char)))
+      (cons the-car (restore write-char)))))
+
+; Symbols
+
+(define (dump-symbol obj write-char)
+  (dump-type type/symbol write-char)
+  (dump-a-string (symbol-case-converter (symbol->string obj)) write-char))
+
+(define-restorer! type/symbol
+  (lambda (c read-char)
+    c ;ignored
+    (string->symbol (symbol-case-converter (restore-a-string read-char)))))
+
+
+; Numbers
+;   <space> ... _   represent  0 ... 63,
+;  {<space> ... {_  represent  64 ... 127,     -- { is ascii 123 
+;  |<space> ... |_  represent  128 ... 191,    -- | is ascii 124
+;  }<space> ... }_  represent  192 ... 256.    -- } is ascii 125
+
+(define (dump-number n write-char)
+  (if (not (communicable-number? n))
+      (error "can't dump this number" n))
+  (if (and (integer? n)
+	   (>= n 0)
+	   (< n 256))
+      (dump-byte n write-char)
+      (begin (dump-type type/number write-char)
+	     ;; Note logarithmic recursion
+	     (dump-a-string (number->string n comm-radix) write-char))))
+
+(define (communicable-number? n) #t)  ;this gets redefined in client
+
+(define (dump-byte n write-char)  ;Dump a number between 0 and 255
+  (if (< n 64)
+      (write-char (ascii->char (+ n ascii-space)))
+      (begin (write-char (ascii->char (+ (arithmetic-shift n -6)
+					 122)))
+	     (write-char (ascii->char (+ (bitwise-and n 63)
+					 ascii-space))))))
+
+(define ascii-space (char->ascii #\space)) ;32
+
+(define (restore-small-integer c read-char)
+  (- (char->ascii c) ascii-space))
+
+(do ((i (+ ascii-space 63) (- i 1)))
+    ((< i ascii-space))
+  (define-restorer! (ascii->char i) restore-small-integer))
+
+(define (restore-medium-integer c read-char)
+  (+ (arithmetic-shift (- (char->ascii c) 122) 6)
+     (- (char->ascii (read-char)) ascii-space)))
+
+(do ((i 123 (+ i 1)))
+    ((> i 125))
+  (define-restorer! (ascii->char i) restore-medium-integer))
+
+(define (restore-number read-char)
+  (let ((c (read-char)))
+    (if (char=? c type/number)
+	(string->number (restore-a-string read-char) comm-radix)
+	(let ((n (char->ascii c)))
+	  (if (> n 122)
+	      (restore-medium-integer c read-char)
+	      (- n ascii-space))))))
+
+(define-restorer! type/number
+  (lambda (c read-char)
+    c ;ignored
+    (string->number (restore-a-string read-char) comm-radix)))
+
+(define comm-radix 16)
+
+
+
+
+; String literals
+
+(define (dump-string obj write-char)
+  (dump-type type/string write-char)
+  (dump-a-string obj write-char))
+
+(define-restorer! type/string
+  (lambda (c read-char)
+    c ;ignored
+    (restore-a-string read-char)))
+
+; Characters
+
+(define (dump-char-literal obj write-char)
+  (dump-type type/char write-char)
+  (dump-a-char obj write-char))
+
+(define-restorer! type/char
+  (lambda (c read-char)
+    c ;ignored
+    (restore-a-char read-char)))
+
+; Vectors
+
+(define (dump-vector obj write-char depth)
+  (dump-vector-like obj write-char depth
+		    type/vector vector-length vector-ref))
+
+(define (dump-template obj write-char depth)
+  (dump-vector-like obj write-char depth
+		    type/template template-length template-ref))
+
+(define (dump-vector-like obj write-char depth type vector-length vector-ref)
+  (if (= depth 0)
+      (dump-ellipsis obj write-char)
+      (let ((depth (- depth 1))
+	    (len (vector-length obj)))
+	(dump-type type write-char)
+	(dump-length len write-char)
+	(do ((i 0 (+ i 1)))
+	    ((= i len) 'done)
+	  (dump (vector-ref obj i) write-char depth)))))
+
+(define (restore-vector-like make-vector vector-set!)
+  (lambda (c read-char)
+    c ;ignored
+    (let* ((len (restore-length read-char))
+	   (v (make-vector len #\?)))
+      (do ((i 0 (+ i 1)))
+	  ((= i len) v)
+	(vector-set! v i (restore read-char))))))
+
+(define-restorer! type/vector
+  (restore-vector-like make-vector vector-set!))
+
+(define-restorer! type/template
+  (restore-vector-like make-template template-set!))
+  
+; Code vectors
+
+(define (dump-code-vector obj write-char)
+  (dump-type type/code-vector write-char)
+  (let ((len (code-vector-length obj)))
+    (dump-length len write-char)
+    (do ((i 0 (+ i 1)))
+	((= i len) 'done)
+      (dump-byte (code-vector-ref obj i) write-char))))
+
+(define-restorer! type/code-vector
+  (lambda (c read-char)
+    c					;ignored
+    (let* ((len (restore-length read-char))
+	   (cv (make-code-vector len 0)))
+      (do ((i 0 (+ i 1)))
+	  ((= i len) cv)
+	(code-vector-set! cv i
+			  (restore-number read-char))))))
+
+; Locations
+
+(define (dump-location obj write-char)
+  (dump-type type/location write-char)
+  (dump-number (location->uid obj) write-char))
+
+(define (location->uid obj)
+  (or ((fluid $dump-index) obj)
+      (location-id obj)))
+
+(define-restorer! type/location
+  (lambda (c read-char)
+    c ;ignored
+    (uid->location (restore-number read-char))))
+
+(define (uid->location uid)
+  (or ((fluid $restore-index) uid)
+      (table-ref uid->location-table uid)
+      (let ((loc (make-undefined-location uid)))
+	(note-location! loc)
+	loc)))
+(define $restore-index (make-fluid (lambda (uid) #f)))
+
+(define uid->location-table (make-table))
+
+(define (note-location! den)
+  (table-set! uid->location-table
+	      (location-id den)
+	      den))
+
+(define $dump-index (make-fluid (lambda (loc) #f)))
+
+; For simulation purposes, it's better for location uid's not to
+; conflict with any that might be in the base Scheme 48 system.  (In the
+; real server system there isn't any base Scheme 48 system, so there's
+; no danger of conflict.)
+
+; (define location-uid-origin 5000)
+
+
+; Closure
+
+(define (dump-closure obj write-char)
+  (dump-type type/closure write-char)
+  (let ((id (template-info (closure-template obj))))
+    (dump-number (if (integer? id) id 0) write-char)))
+
+(define-restorer! type/closure
+  (lambda (c read-char)
+    c ;ignored
+    (make-random (list 'closure (restore-number read-char)))))
+
+
+; Random
+
+(define random-type (make-record-type 'random '(disclosure)))
+(define make-random (record-constructor random-type '(disclosure)))
+(define-record-discloser random-type
+  (let ((d (record-accessor random-type 'disclosure)))
+    (lambda (r) (cons "Remote" (d r)))))
+
+(define (dump-random obj write-char depth)
+  (dump-type type/random write-char)
+  (dump (or (disclose obj) (list '?))
+	    write-char
+	    depth))
+
+(define-restorer! type/random
+  (lambda (c read-char)
+    (make-random (restore read-char))))
+
+
+
+; Ellipsis
+
+(define (dump-ellipsis obj write-char)
+  (dump-type type/ellipsis write-char))
+
+(define-restorer! type/ellipsis
+  (lambda (c read-char) (make-random (list (string->symbol "---")))))
+
+
+
+
+; Auxiliaries:
+
+; Strings (not necessarily preceded by type code)
+
+(define (dump-a-string obj write-char)
+  (let ((len (string-length obj)))
+    (dump-length len write-char)
+    (do ((i 0 (+ i 1)))
+	((= i len) 'done)
+      (dump-a-char (string-ref obj i) write-char))))
+
+(define (restore-a-string read-char)
+  (let* ((len (restore-length read-char))
+	 (str (make-string len #\?)))
+    (do ((i 0 (+ i 1)))
+	((= i len) str)
+      (string-set! str i (restore-a-char read-char)))))
+
+(define (dump-a-char c write-char)
+  (write-char c))
+
+(define (restore-a-char read-char)
+  (read-char))
+
+
+; Type characters
+
+(define (dump-type c write-char)
+  (write-char c))
+(define (restore-type read-char)
+  (read-char))
+
+(define dump-length dump-number)
+(define restore-length restore-number)
+
+;(define char->ascii char->integer)  -- defined in p-features.scm
+;(define ascii->char integer->char)  -- ditto
+
+
+; Miscellaneous support
+
+(define (unspecific? obj)
+  (eq? obj *unspecific*))
+
+(define *unspecific* (if #f #f)) ;foo
+
+;(define (integer->digit-char n)
+;  (ascii->char (+ n (if (< n 10) ascii-zero a-minus-ten))))
+;
+;(define (digit-char->integer c)
+;  (cond ((char-numeric? c)
+;         (- (char->ascii c) ascii-zero))
+;        ((char=? c #\#) 0)
+;        (else
+;         (- (char->ascii (char-downcase c)) a-minus-ten))))
+;
+;(define ascii-zero (char->ascii #\0))
+;
+;(define a-minus-ten (- (char->integer #\a) 10))
+
+; These modified from s48/boot/transport.scm
+
+(define (string-case-converter string)
+  (let ((new (make-string (string-length string) #\?)))
+    (do ((i 0 (+ i 1)))
+	((>= i (string-length new)) new)
+      (string-set! new i (invert-case (string-ref string i))))))
+
+(define (invert-case c)
+  (cond ((char-upper-case? c) (char-downcase c))
+	((char-lower-case? c) (char-upcase c))
+	(else c)))
+
+(define symbol-case-converter
+  (if (char=? (string-ref (symbol->string 't) 0) #\t)
+      (lambda (string) string)
+      string-case-converter))
+
+
+; ASCII
+;   !"#$%&'()*+,-./0123456789:;<=>?
+;  @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_
+;  `abcdefghijklmnopqrstuvwxyz{|}~
+
+;(define (tst x)
+;  (let ((l '()))
+;    (dump x (lambda (c) (set! l (cons c l))) -1)
+;    (let ((l (reverse l)))
+;      (restore (lambda ()
+;                 (let ((c (car l)))
+;                   (set! l (cdr l))
+;                   c))))))
+
+;(define cwcc call-with-current-continuation)
+;
+;(define (tst x)
+;  (letrec ((write-cont (lambda (ignore)
+;                         (dump x
+;                               (lambda (c)
+;                                 (cwcc (lambda (k)
+;                                         (set! write-cont k)
+;                                         (read-cont c))))
+;                               -1)))
+;           (read-cont #f))
+;    (restore (lambda ()
+;               (cwcc (lambda (k)
+;                       (set! read-cont k)
+;                       (write-cont 'ignore)))))))
diff --git a/scheme/big/external.scm b/scheme/big/external.scm
new file mode 100644
index 0000000..d083ae5
--- /dev/null
+++ b/scheme/big/external.scm
@@ -0,0 +1,127 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Code for keeping external pointers in a table similar to the symbol table.
+;
+; The entry points for this code are:
+;
+; (GET-EXTERNAL string)    returns an external pointer
+; (LOOKUP-ALL-EXTERNALS)   looks up new values for all external pointers;
+;                          ideally this should be called automatically
+;                          on startup
+;
+; (DYNAMIC-LOAD filename)  loads the file into the current image
+;
+; The following used to be in the PRIMITIVES interface when externals were
+; a primitive data type.
+;
+; external?
+; external-name
+; external-value
+; (external-lookup external)
+; (call-external external . args)
+
+; New, non-primitive data type.
+
+(define-record-type external :external
+  (make-external name value)
+  external?
+  (name external-name)
+  (value external-value))
+
+; Table of externals.
+
+(define *the-external-table* #f)
+
+(define (flush-the-external-table!)
+  (set! *the-external-table* #f))
+
+(define (restore-the-external-table!)
+  (set! *the-external-table* (make-string-table))
+  (vector-for-each (lambda (external)
+		     (table-set! *the-external-table*
+				 (external-name external)
+				 external))
+		   (find-all-records :external)))
+
+(define (gc-externals)
+  (flush-the-external-table!)
+  (collect)
+  (restore-the-external-table!))
+
+(define (vector-for-each proc vector)
+  (do ((i 0 (+ i 1)))
+      ((>= i (vector-length vector))
+       (unspecific))
+    (proc (vector-ref vector i))))
+
+(restore-the-external-table!)
+
+;----------------
+; Making new externals.
+
+(define (get-external name)
+  (cond ((table-ref *the-external-table* name)
+	 => (lambda (x) x))
+	(else
+	 (let* ((value (make-code-vector 4 0))
+		(new (make-external name value)))
+	   (table-set! *the-external-table* name new)
+	   (if (not (external-lookup name value))
+	       (warn "External not found" name))
+	   new))))
+
+(import-lambda-definition external-lookup (name value) "s48_external_lookup")
+
+; No longer necessary, as all strings now end with nulls.
+
+(define (null-terminate str)
+  str)
+
+;----------------
+; Re-lookup all externals.  This needs to be done whenever we resume an image.
+
+(define (lookup-all-externals)
+  (cond ((null? (really-lookup-all-externals))
+	 #t)
+	(else
+	 (display "GCing to try to remove unbound externals")
+	 (newline)
+	 (gc-externals)
+	 (let ((losers (really-lookup-all-externals)))
+	   (if (null? losers)
+	       #t
+	       (let ((out (current-error-port)))
+		 (display "Unbound external(s):" out)
+		 (for-each (lambda (name)
+			     (write-char #\space out)
+			     (display name out))
+			   losers)
+		 #f))))))
+
+
+; Quietly look up all externals, returning #F if unsuccessful
+
+(define (try-to-lookup-all-externals)
+  (null? (really-lookup-all-externals)))
+
+; Look up all externals, returning a list of the names of those that cannot
+; be found.
+
+(define (really-lookup-all-externals)
+  (let ((losers '()))
+    (table-walk (lambda (name external)
+		  (if (not (external-lookup name (external-value external)))
+		      (set! losers (cons name losers))))
+		*the-external-table*)
+    losers))
+
+;----------------
+
+(define (call-external external . args)
+  (apply call-external-value (external-value external)
+	                     (external-name external)
+			     args))
+
+;----------------
+
+(import-lambda-definition dynamic-load (filename) "s48_dynamic_load")
diff --git a/scheme/big/filename.scm b/scheme/big/filename.scm
new file mode 100644
index 0000000..30cd56a
--- /dev/null
+++ b/scheme/big/filename.scm
@@ -0,0 +1,115 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Silly file name utilities
+; These try to be operating-system independent, but fail, of course.
+
+; Namelist = ((dir ...) basename type)
+;         or ((dir ...) basename)
+;	  or (dir basename type)
+;	  or (dir basename)
+;	  or basename
+
+(define (namestring namelist dir default-type)
+  (let* ((namelist (if (list? namelist) namelist (list '() namelist)))
+	 (subdirs (if (list? (car namelist))
+		      (car namelist)
+		      (list (car namelist))))
+	 (basename (cadr namelist))
+	 (type (if (null? (cddr namelist))
+		   (if (string? basename)
+		       #f
+		       default-type)
+		   (caddr namelist))))
+    (string-append (or dir "")
+		   (apply string-append
+			  (map (lambda (subdir)
+				 (string-append
+				  (namestring-component subdir)
+				  directory-component-separator))
+			       subdirs))
+		   (namestring-component basename)
+		   (if type
+		       (string-append type-component-separator
+				      (namestring-component type))
+		       ""))))
+
+(define directory-component-separator "/") ;unix sux
+(define type-component-separator ".")
+
+(define (namestring-component x)
+  (cond ((string? x) x)
+	((symbol? x)
+	 (list->string (map file-name-preferred-case
+			    (string->list (symbol->string x)))))
+	(else (error "bogus namelist component" x))))
+
+(define file-name-preferred-case char-downcase)
+
+(define *scheme-file-type* 'scm)
+(define *load-file-type* *scheme-file-type*)  ;#F for Pseudoscheme or T
+
+
+
+; Interface copied from gnu emacs:
+
+;file-name-directory           
+;  Function: Return the directory component in file name NAME.
+;file-name-nondirectory        
+;  Function: Return file name NAME sans its directory.
+;file-name-absolute-p          
+;  Function: Return t if file FILENAME specifies an absolute path name.
+;substitute-in-file-name       
+;  Function: Substitute environment variables referred to in STRING.
+;expand-file-name              
+;  Function: Convert FILENAME to absolute, and canonicalize it.
+
+(define (file-name-directory filename)
+  (substring filename 0 (file-nondirectory-position filename)))
+
+(define (file-name-nondirectory filename)
+  (substring filename
+	     (file-nondirectory-position filename)
+	     (string-length filename)))
+
+(define (file-nondirectory-position filename)
+  (let loop ((i (- (string-length filename) 1)))
+    (cond ((< i 0) 0)
+	  ;; Heuristic.  Should work for DOS, Unix, VMS, MacOS.
+          ((string-posq (string-ref filename i) "/:>]\\") (+ i 1))
+          (else (loop (- i 1))))))
+
+(define (string-posq thing s)
+  (let loop ((i 0))
+    (cond ((>= i (string-length s)) #f)
+          ((eq? thing (string-ref s i)) i)
+          (else (loop (+ i 1))))))
+
+
+
+; Directory translations.
+; E.g. (set-translation! "foo;" "/usr/mumble/foo/")
+
+(define *translations* '())
+
+(define (translations) *translations*)
+
+(define (set-translation! from to)
+  (let ((probe (assoc from *translations*)))
+    (if probe
+	(set-cdr! probe to)
+	(set! *translations* (cons (cons from to) *translations*)))))
+
+(define (translate name)
+  (let ((len (string-length name)))
+    (let loop ((ts *translations*))
+      (if (null? ts)
+	  name
+	  (let* ((from (caar ts))
+		 (to (cdar ts))
+		 (k (string-length from)))
+	    (if (and to
+		     (<= k len)
+		     (string=? (substring name 0 k) from))
+		(string-append to (substring name k len))
+		(loop (cdr ts))))))))
diff --git a/scheme/big/finite-type.scm b/scheme/big/finite-type.scm
new file mode 100644
index 0000000..e720d4c
--- /dev/null
+++ b/scheme/big/finite-type.scm
@@ -0,0 +1,164 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Finite types (i.e. record types with a fixed set of elements).
+;
+; An enumeration is really a special case of a finite type.
+;
+; (define-finite-type <id and dispatch-macro>
+;   <type name>
+;   (<constructor field name> ...)
+;   <predicate>
+;   <vector of elements>
+;   <name accessor>
+;   <index accessor>
+;   (<field name> <field accessor> [<field setter>])
+;   ...
+;   ((<element name> <constructor field value> ...)
+;    ...))
+;
+; This is equivalent to
+;
+; (define-record-type <id and dispatch-macro>
+;   <type name>
+;   (maker name index <constructor field name> ...)
+;   <predicate>
+;   (name <name accessor>)
+;   (index <index accessor>)
+;   (<field name> <field accessor> [<field setter>])
+;   ...)
+;
+; (define <vector of elements>
+;   (vector (maker <element name> 0 <constructor field value>)
+;           (maker <element name> 1 <constructor field value>)
+;           ...))
+;
+; (define-dispatch-macro <id and dispatch-macro>
+;   (<element name> ...)
+;   <vector-of-elements>)
+;
+; where DEFINE-DISPATCH-MACRO defines an ENUM-like dispatcher.
+;
+;(define-finite-type foo :foo       ; id and type
+;  foo?                             ; predicate
+;  foo-elements                     ; vector containing all elements
+;  foo-name                         ; name accessor
+;  foo-index                        ; index accessor
+;  (color foo-color set-foo-color!) ; any additional fields
+;  ((name color)                    ; element pattern
+;   (a 'red)                        ; the elements themselves
+;   (b 'green)
+;   (c 'puce)
+;   (d 'taupe)))
+;
+; (foo a) -> #{foo a}
+
+(define-syntax define-finite-type
+  (lambda (form rename compare)
+    (let ((destruct (lambda (proc)
+		      (apply proc (cdr form))))
+	  (%define-record-type (rename 'define-record-type))
+	  (%define-record-discloser (rename 'define-record-discloser))
+	  (%define (rename 'define))
+	  (%begin (rename 'begin))
+	  (%lambda (rename 'lambda))
+	  (%vector (rename 'vector))
+	  (%list (rename 'list))
+	  (%define-dispatch (rename 'define-dispatch))
+	  (%make-immutable! (rename 'make-immutable!))
+	  (%maker (rename 'maker))
+	  (%name (rename 'name))
+	  (%index (rename 'index))
+	  (%blah (rename 'blah)))
+      (destruct (lambda (foo :foo pattern foo? foo-elements foo-name foo-index
+			 . more)
+		  (let* ((fields (do ((more more (cdr more))
+				      (fields '() (cons (car more) fields)))
+				     ((or (null? more)
+					  (pair? (caar more)))
+				      (reverse fields))))
+			 (elts (car (reverse more)))
+			 (names (map car elts)))
+		    `(,%begin
+		      (,%define-record-type ,foo ,:foo
+			  (,%maker ,%name ,%index . ,pattern)
+			  ,foo?
+			  (,%name ,foo-name)
+			  (,%index ,foo-index)
+			  . ,fields)
+		      (,%define-record-discloser ,:foo
+			  (,%lambda (,%blah)
+			      (,%list ',foo (,foo-name ,%blah))))
+		      (,%define ,foo-elements
+			  (,%make-immutable!
+			    (,%vector . ,(do ((elts elts (cdr elts))
+				  	      (i 0 (+ i 1))
+					      (res '() `((,%maker ',(caar elts)
+								  ,i
+								  . ,(cdar elts))
+							 . ,res)))
+					     ((null? elts)
+					      (reverse res))))))
+		      (,%define-dispatch ,foo ,names ,foo-elements)))))))
+  (define-record-type define-record-discloser define-dispatch
+   define begin lambda vector list))
+
+; (define-dispatch <name> (<member name> ...) <vector of members>)
+;
+; This defines <name> to be a macro (<name> X) that looks X up in
+; the list of member names and returns the corresponding element of
+; <vector of members>.
+;
+; (define-dispatch foo (a b c) members)
+; (foo b) -expands-into-> (vector-ref members 1)
+
+(define-syntax define-dispatch
+  (lambda (form0 rename0 compare0)
+    (let ((name (cadr form0))
+	  (names (caddr form0))
+	  (elts (cadddr form0))
+	  (%vector-ref (rename0 'vector-ref))
+	  (%code-quote (rename0 'code-quote)))
+      `(define-syntax ,name
+	 (lambda (form1 rename1 compare1)
+	   (let ((elt (cadr form1)))
+	     (let loop ((names ',names) (i 0))
+	       (cond ((null? names)
+		      form1)
+		     ((eq? elt (car names))
+		      (list (,%code-quote ,%vector-ref) (rename1 ',elts) i))
+		     (else
+		      (loop (cdr names) (+ i 1))))))))))
+  (vector-ref code-quote))
+
+; (define-enumerated-type <id and dispatch-macro>
+;   <type name>
+;   <predicate>
+;   <vector of elements>
+;   <name accessor>
+;   <index accessor>
+;   (<element name> ...))
+;
+; This is a simplified version that has no additional fields.  It avoids
+; a lot of unnecessary parens around the element names.
+;
+; The above expands into:
+;
+; (define-finite-type <id and dispatch-macro>
+;   <type name>
+;   <predicate>
+;   <vector of elements>
+;   <name accessor>
+;   <index accessor>
+;   ((name)
+;    (<element name>)
+;    ...))
+
+(define-syntax define-enumerated-type
+  (syntax-rules ()
+    ((define-enumerated-type id type-name predicate elements
+       name-accessor index-accessor
+       (element ...))
+     (define-finite-type     id type-name () predicate elements
+       name-accessor index-accessor
+       ((element) ...)))))
+
diff --git a/scheme/big/format.scm b/scheme/big/format.scm
new file mode 100644
index 0000000..20895f5
--- /dev/null
+++ b/scheme/big/format.scm
@@ -0,0 +1,154 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Quicky FORMAT
+;
+; (FORMAT port string . args)
+;
+; PORT is one of:
+; an output port, in which case FORMAT prints to the port;
+; #T, FORMAT prints to the current output port;
+; #F, FORMAT returns a string.
+;
+; The following format directives have been implemented:
+; ~~  -prints a single ~
+; ~A  -prints the next argument using DISPLAY
+; ~D  -prints the next argument using NUMBER->STRING (`D'ecimal)
+; ~S  -prints the next argument using WRITE
+; ~%  -prints a NEWLINE character
+; ~&  -prints a NEWLINE character if the previous printed character was not one
+;     (this is implemented using FRESH-LINE)
+; ~?  -performs a recursive call to FORMAT using the next two arguments as the
+;      string and the list of arguments
+;
+; FORMAT is case-insensitive with respect to letter directives (~a and ~A have
+; the same effect).
+
+; The entry point.  Gets the port and writes the output.
+; Get the appropriate writer for the port specification.
+
+(define (format port string . args)
+  (cond ((not port)
+ 	 (call-with-string-output-port
+  	   (lambda (port)
+  	     (real-format port string args))))
+	((eq? port #t)
+	 (real-format (current-output-port) string args))
+	((output-port? port)
+	 (real-format port string args))
+	(else
+	 (error "invalid port argument to FORMAT" port))))
+
+; Loop down the format string printing characters and dispatching on directives
+; as required.  Procedures for the directives are in a vector indexed by
+; character codes.  Each procedure takes four arguments: the format string,
+; the index of the next unused character in the format string, the list of
+; remaining arguments, and the writer.  Each should return a list of the unused
+; arguments.
+
+(define (real-format out string all-args)
+  (let loop ((i 0) (args all-args))
+    (cond ((>= i (string-length string))
+	   (if (null? args)
+	       #f
+	       (error "too many arguments to FORMAT" string all-args)))
+	  ((char=? #\~ (string-ref string i))
+	   (if (= (+ i 1) (string-length string))
+	       (error "invalid format string" string i)
+	       (loop (+ i 2)
+		     ((vector-ref format-dispatch-vector
+				  (char->ascii (string-ref string (+ i 1))))
+		      string
+		      (+ i 2)
+		      args
+		      out))))
+	  (else
+	   (write-char (string-ref string i) out)
+	   (loop (+ i 1) args)))))
+
+; One more than the highest integer that CHAR->ASCII may return.
+(define number-of-char-codes ascii-limit)
+
+; The vector of procedures implementing format directives.
+
+(define format-dispatch-vector
+  (make-vector number-of-char-codes
+	       (lambda (string i args out)
+		 (error "illegal format command"
+			string
+			(string-ref string (- i 1))))))
+
+; This implements FORMAT's case-insensitivity.
+
+(define (define-format-command char proc)
+  (vector-set! format-dispatch-vector (char->ascii char) proc)
+  (if (char-alphabetic? char)
+      (vector-set! format-dispatch-vector
+		   (char->ascii (if (char-lower-case? char)
+				    (char-upcase char)
+				    (char-downcase char)))
+		   proc)))
+
+; Write a single ~ character.
+
+(define-format-command #\~
+  (lambda (string i args out)
+    (write-char #\~ out)
+    args))
+
+; Newline
+
+(define-format-command #\%
+  (lambda (string i args out)
+    (newline out)
+    args))
+
+; Fresh-Line
+
+(define-format-command #\&
+  (lambda (string i args out)
+    (fresh-line out)
+    args))
+
+; Display (`A' is for ASCII)
+
+(define-format-command #\a
+  (lambda (string i args out)
+    (check-for-format-arg args)
+    (display (car args) out)
+    (cdr args)))
+
+; Decimals
+
+(define-format-command #\d
+  (lambda (string i args out)
+    (check-for-format-arg args)
+    (if (not (number? (car args)))
+	(error "invalid number argument to ~D in FORMAT" string (car args)))
+    (display (number->string (car args) 10) out)
+    (cdr args)))
+
+; Write (`S' is for S-expression)
+
+(define-format-command #\s
+  (lambda (string i args out)
+    (check-for-format-arg args)
+    (write (car args) out)
+    (cdr args)))
+
+; Recursion
+
+(define-format-command #\?
+  (lambda (string i args out)
+    (check-for-format-arg args)
+    (check-for-format-arg (cdr args))
+    (real-format out (car args) (cadr args))
+    (cddr args)))
+
+; Signal an error if ARGS is empty.
+
+(define (check-for-format-arg args)
+  (if (null? args)
+      (error "insufficient number of arguments to FORMAT")))
+
+
diff --git a/scheme/big/general-table.scm b/scheme/big/general-table.scm
new file mode 100644
index 0000000..632ead6
--- /dev/null
+++ b/scheme/big/general-table.scm
@@ -0,0 +1,270 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Hash table package that allows for different hash and comparison functions.
+;
+; The fields in a table are:
+;  size - the number of entries
+;  data - an a-list or vector of a-lists
+;  ref  - a procedure: [table index] -> value
+;  set  - a procedure: [table index new-value] -> void
+;
+; In small tables the data is stored in an a-list and no hashing is used.
+; In large tables the data is stored in a vector of a-lists, with hashing
+; used to index into the vector.  When a small table grows large the REF
+; and SET fields are replaced with vector-oriented versions.
+
+(define-record-type table :table
+  (really-make-table size data ref set)
+  table?
+  (size table-size set-table-size!)
+  (data table-data set-table-data!)
+  (ref table-ref-procedure set-table-ref-procedure!)
+  (set table-set!-procedure set-table-set!-procedure!))
+
+(define (table-ref table key)
+  ((table-ref-procedure table) table key))
+
+(define (table-set! table key value)
+  ((table-set!-procedure table) table key value))
+
+; This number is a guess
+(define linear-table-size-limit 15)
+
+(define (next-table-size count)		; Figure out next good size for table.
+  (+ (* count 3) 1))
+
+; A table-maker is a thunk that returns a new, empty table each time it is
+; called.  There are four functions involved:
+;   assoc : [key alist] -> entry or #f
+;   ref-proc : [table key] -> entry or #f
+;   x->hash-table! : [assoc hash-function] -> void
+;   set!-proc : [table key value] -> void
+; X->HASH-TABLE! replaces the data, ref, and set fields of the table, making
+; it into a hash table.
+
+(define (make-table-maker comparison-function hash-function)
+  (assoc->table-maker (make-assoc comparison-function)
+		      hash-function))
+
+(define (assoc->table-maker assoc hash-function)
+  (let* ((ref-proc (make-linear-table-ref assoc))
+	 (x->hash-table! (make->hash-table assoc hash-function))
+	 (set!-proc (make-linear-table-set! assoc x->hash-table!)))
+    (lambda ()
+      (really-make-table 0 null-entry ref-proc set!-proc))))
+
+;----------------
+; A-lists.  These are currently actual a-lists, because ASSQ is a VM primitive
+; and thus very fast.
+
+(define null-entry '())  ; #f
+
+(define (new-entry key val others)
+  ;(vector key val others)
+  (cons (cons key val) others))
+
+; This abstraction is violated at times.
+(define entry-value cdr)
+(define entry-key car)
+(define set-entry-value! set-cdr!)
+
+; ENTRIES is known to contain ENTRY.
+
+(define (delete-entry! entries entry)
+  (if (eq? entry (car entries))
+      (cdr entries)
+      (begin
+	(let loop ((entries entries))
+	  (if (eq? entry
+		   (cadr entries))
+	      (set-cdr! entries (cddr entries))
+	      (loop (cdr entries))))
+	entries)))
+
+(define (make-assoc pred)
+  (if (eq? pred eq?)
+      assq
+      (lambda (thing alist)
+	(let loop ((alist alist))
+	  (cond ((null? alist)
+		 #f)
+		((pred thing (caar alist))
+		 (car alist))
+		(else
+		 (loop (cdr alist))))))))
+
+; Using actual a-lists allows us to use ASSQ instead of the following.
+
+;(define eq?-assoc
+;  (lambda (thing alist)
+;    (let loop ((alist alist))
+;      (cond ((not alist)
+;             #f)
+;            ((eq? thing (vector-ref alist 0))
+;             alist)
+;            (else
+;             (loop (vector-ref alist 2)))))))
+
+;----------------
+; Turn some version of ASSOC into a table reference procedure for a-list
+; tables.
+
+(define (make-linear-table-ref assoc)
+  (lambda (table key)
+    (let ((probe (assoc key (table-data table))))
+      (if probe (entry-value probe) #f))))
+
+; Turn some version of ASSOC and a hash function into a table set! procedure
+; for a-list tables.  If the table gets too big it is turned into a hash table.
+
+(define (make-linear-table-set! assoc x->hash-table!)
+  (lambda (table key value)
+    (let* ((data (table-data table))
+	   (probe (assoc key data)))
+      (cond (probe
+	     (if value
+		 (set-entry-value! probe value)
+		 (begin
+		   (set-table-data! table (delete-entry! data probe))
+		   (set-table-size! table (- (table-size table) 1)))))
+	    (value
+	     (set-table-data! table (new-entry key value data))
+	     (let ((size (table-size table)))
+	       (if (< size linear-table-size-limit)
+		   (set-table-size! table (+ size 1))
+		   (x->hash-table! table size))))))))
+
+; Return a function to transform linear tables into hash tables.
+
+(define (make->hash-table assoc hash-function)
+  (let ((hash-table-ref (make-hash-table-ref assoc hash-function))
+	(hash-table-set! (make-hash-table-set! assoc hash-function)))
+    (lambda (table size)
+      (let ((data (table-data table)))
+	(set-table-ref-procedure! table hash-table-ref)
+	(set-table-set!-procedure! table hash-table-set!)
+	(table-expand-table! table (next-table-size size))
+	(table-enter-alist! table data)))))
+
+(define (make-hash-table-ref assoc hash-function)
+  (lambda (table key)
+    (let* ((data (table-data table))
+	   (h (remainder (hash-function key)
+			 (vector-length data)))
+	   (alist (vector-ref data h))
+	   (probe (assoc key alist)))
+      (if probe (entry-value probe) #f))))
+	       
+(define (make-hash-table-set! assoc hash-function)
+  (lambda (table key value)
+    (let* ((data (table-data table))
+	   (h (remainder (hash-function key)
+			 (vector-length data)))
+	   (alist (vector-ref data h))
+	   (probe (assoc key alist)))
+      (cond (probe
+	     (if value
+		 (set-entry-value! probe value)
+		 (begin
+		   (vector-set! data h (delete-entry! alist probe))
+		   (set-table-size! table (- (table-size table) 1)))))
+	    (value
+	     (vector-set! data h (new-entry key value alist))
+	     (let ((size (+ (table-size table) 1)))
+	       (if (< size (vector-length data))
+		   (set-table-size! table size)
+		   (expand-hash-table! table size))))))))
+
+(define (expand-hash-table! table size)
+  (let ((data (table-data table)))
+    (table-expand-table! table (next-table-size size))
+    (do ((i 0 (+ i 1)))
+	((>= i (vector-length data)))
+      (table-enter-alist! table (vector-ref data i)))))
+
+(define (table-enter-alist! table alist)
+  (let ((set!-proc (table-set!-procedure table)))
+    (do ((alist alist (cdr alist)))
+	((null? alist))
+      (set!-proc table (caar alist) (cdar alist)))))
+
+; Reset the size and data of a table.  The size will be incremented as
+; the entries are added back into the table.
+
+(define (table-expand-table! table vector-size)
+  (set-table-size! table 0)
+  (set-table-data! table (make-vector vector-size null-entry)))
+
+(define (table-walk proc table)
+  (really-table-walk (lambda (v)
+		       (proc (entry-key v) (entry-value v)))
+		     table))
+		       
+(define (really-table-walk proc table)
+  (let ((data (table-data table)))
+    (cond ((null? data))
+	  ((pair? data)
+	   (alist-walk proc data))
+	  (else
+	   (do ((i 0 (+ i 1)))
+	       ((>= i (vector-length data)))
+	     (alist-walk proc (vector-ref data i)))))))
+
+(define (alist-walk proc alist)
+  (do ((alist alist (cdr alist)))
+      ((null? alist))
+    (proc (car alist))))
+
+(define (make-table-immutable! table)
+  (really-table-walk make-immutable! table)
+  (make-immutable! (table-data table))
+  (make-immutable! table))
+
+(define (table->entry-list table)
+  (let ((list '()))
+    (table-walk (lambda (k v)
+		  (set! list (cons v list)))
+		table)
+    list))
+
+; Actual tables
+
+; The default hash function only on works on things that would work in
+; a CASE expression.  Even then, numbers don't really "work," since
+; they are compared using eq?.
+
+(define (default-table-hash-function obj)
+  (cond ((symbol? obj) (string-hash (symbol->string obj)))
+	((integer? obj)
+	 (if (< obj 0) (- -1 obj) obj))
+	((char? obj) (+ 333 (char->integer obj)))
+	((eq? obj #f) 3001)
+	((eq? obj #t) 3003)
+	((null? obj) 3005)
+	(else (error "value cannot be used as a table key" obj))))
+
+(define eqv?-assoc (make-assoc eqv?))
+
+(define (default-table-assoc key alist)
+  (if (number? key)
+      (eqv?-assoc key alist)
+      (assq key alist)))
+
+; (define string-hash (structure-ref features string-hash))
+
+(define (symbol-hash symbol)
+  (string-hash (symbol->string symbol)))
+
+(define make-table
+  (let ((make-usual-table (assoc->table-maker default-table-assoc
+					      default-table-hash-function)))
+    (lambda hash-function-option
+      (if (null? hash-function-option)
+	  (make-usual-table)
+	  ((assoc->table-maker default-table-assoc
+			       (car hash-function-option)))))))
+
+(define make-string-table  (make-table-maker string=? string-hash))
+(define make-symbol-table  (make-table-maker eq?      symbol-hash))
+(define make-integer-table (make-table-maker =	      abs))
diff --git a/scheme/big/import-def.scm b/scheme/big/import-def.scm
new file mode 100644
index 0000000..a2108a5
--- /dev/null
+++ b/scheme/big/import-def.scm
@@ -0,0 +1,67 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Two macros:
+;
+; (import-definition <id>)
+;   ->
+; (define <id> (lookup-imported-binding "<id with - becoming _>"))
+;
+; (import-definition <id> <string id>)
+;   ->
+; (define <id> (lookup-imported-binding <string-id>))
+;
+; (import-lambda-definition <id> (<formal> ...))
+;   ->
+; (begin
+;   (define temp (lookup-imported-binding "<id with - becoming _>"))
+;   (define <id>
+;     (lambda (<formal> ...)
+;       (call-imported-binding temp <formal> ...))))
+;
+; (import-lambda-definition <id> (<formal> ...) <string id>)
+;   ->
+; ...same again using <string id> as the imported name...
+
+(define-syntax import-definition
+  (lambda (exp rename compare)
+    (let ((id (cadr exp))
+	  (%define (rename 'define))
+	  (%lookup-imported-binding (rename 'lookup-imported-binding)))
+      (let ((external-id (if (null? (cddr exp))
+			     (list->string (map (lambda (ch)
+						  (if (char=? ch #\-)
+						      #\_
+						      ch))
+						(string->list
+						 (symbol->string id))))
+			     (caddr exp))))
+	`(,%define ,id
+	    (,%lookup-imported-binding ,external-id))))))
+
+; (import-lambda-definition id (formal ...) [external name])
+
+(define-syntax import-lambda-definition
+  (lambda (exp rename compare)
+    (let ((id (cadr exp))
+	  (formals (caddr exp))
+	  (%define (rename 'define))
+	  (%begin (rename 'begin))
+	  (%lambda (rename 'lambda))
+	  (%call-imported-binding   (rename 'call-imported-binding))
+	  (%lookup-imported-binding (rename 'lookup-imported-binding))
+	  (%binding 		(rename 'binding)))
+      (let ((external-id (if (null? (cdddr exp))
+			     (list->string (map (lambda (ch)
+						  (if (char=? ch #\-)
+						      #\_
+						      ch))
+						(string->list
+						 (symbol->string id))))
+			     (cadddr exp))))
+	`(,%begin
+	   (,%define ,%binding
+	    (,%lookup-imported-binding ,external-id))
+	   (,%define ,id
+	    (,%lambda ,formals
+	      (,%call-imported-binding ,%binding . ,formals))))))))
+
diff --git a/scheme/big/linked-queue.scm b/scheme/big/linked-queue.scm
new file mode 100644
index 0000000..3a291f5
--- /dev/null
+++ b/scheme/big/linked-queue.scm
@@ -0,0 +1,74 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; This file is no longer used.
+
+; Queues implemented as doubly linked lists (because the thread package needs
+; to delete queue entries quickly).
+
+; The exported procedures are those of the simpler queue package, with the
+; addition of DELETE-QUEUE-ENTRY!.  ENQUEUE! returns a queue-entry which can
+; then be passed to DELETE-QUEUE-ENTRY! to remove the thing from the queue.
+
+(define-record-type q-entry :q-entry
+  (make-q-entry data prev next)
+  q-entry?
+  (data q-entry-data)
+  (prev q-entry-prev set-q-entry-prev!)
+  (next q-entry-next set-q-entry-next!))
+
+(define queue? q-entry?)
+
+(define (make-queue)
+  (let ((e (make-q-entry #f #f #f)))
+    (set-q-entry-prev! e e)
+    (set-q-entry-next! e e)
+    e))
+
+(define (queue-empty? q)
+  (eq? (q-entry-next q) q))
+
+(define (enqueue! q thing)
+  (let* ((prev (q-entry-prev q))
+	 (e (make-q-entry thing prev q)))
+    (set-q-entry-prev! q e)
+    (set-q-entry-next! prev e)
+    e))
+
+(define (queue-head q)
+  (let ((e (q-entry-next q)))
+    (if (eq? q e)	;(queue-empty? q)
+	(error "empty queue" q)
+	(q-entry-data e))))
+
+(define (dequeue! q)
+  (let ((e (q-entry-next q)))
+    (cond ((eq? q e)	;(queue-empty? q)
+	   (error "empty queue" q))
+	  (else
+	   (set-q-entry-next! q (q-entry-next e))
+	   (set-q-entry-prev! (q-entry-next q) q)
+	   (q-entry-data e)))))
+
+(define (delete-queue-entry! e)
+  (let ((next (q-entry-next e))
+	(prev (q-entry-prev e)))
+    (set-q-entry-next! prev next)
+    (set-q-entry-prev! next prev)))
+
+(define (queue->list q)
+  (do ((e (q-entry-prev q) (q-entry-prev e))
+       (l '() (cons (q-entry-data e) l)))
+      ((eq? q e) l)))
+
+(define (queue-length q)
+  (do ((e (q-entry-prev q) (q-entry-prev e))
+       (l 0 (+ l 1)))
+      ((eq? q e) l)))
+
+(define (delete-from-queue! q v)
+  (let loop ((e (q-entry-next q)))
+    (cond ((eq? e q))
+	  ((eq? (q-entry-data e) v)
+	   (delete-queue-entry! e))
+	  (else
+	   (loop (q-entry-next e))))))
diff --git a/scheme/big/lu-decomp.scm b/scheme/big/lu-decomp.scm
new file mode 100644
index 0000000..146e628
--- /dev/null
+++ b/scheme/big/lu-decomp.scm
@@ -0,0 +1,144 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; LU Decomposition (a rewriting of a Pascal program from `Numerical Recipes
+; in Pascal'; look there for a detailed description of what is going on).
+
+; A is an NxN matrix that is updated in place.
+; This returns a row permutation vector and the sign of that vector.
+
+(define *lu-decomposition-epsilon* 1.0e-20)
+
+(define (lu-decomposition a)
+  (let* ((n (car (array-shape a)))
+	 (indx (make-vector n))
+	 (sign 1.0)
+	 (vv (make-vector n)))
+
+    (do ((i 0 (+ i 1)))
+	((>= i n))
+      (do ((j 0 (+ j 1))
+	   (big 0.0 (max big (abs (array-ref a i j)))))
+	  ((>= j n)
+	   (if (= big 0.0)
+	       (error "lu-decomposition matrix has a zero row" a i))
+	   (vector-set! vv i (/ big)))))
+
+    (do ((j 0 (+ j 1)))
+	((>= j n))
+      (let ()
+	(define (sum-elts i end)	  
+	  (do ((k 0 (+ k 1))
+	       (sum (array-ref a i j)
+		    (- sum (* (array-ref a i k)
+			      (array-ref a k j)))))
+	      ((>= k end)
+	       sum)))
+
+	(do ((i 0 (+ i 1)))
+	    ((>= i j))
+	  (array-set! a (sum-elts i i) i j))
+
+	(receive (big imax)
+	    (let loop ((i j) (big 0.0) (imax 0))
+	      (if (>= i n)
+		  (values big imax)
+		  (let ((sum (sum-elts i j)))
+		    (array-set! a sum i j)
+		    (let ((temp (* (vector-ref vv i) (abs sum))))
+		      (if (>= temp big)
+			  (loop (+ i 1) temp i)
+			  (loop (+ i 1) big imax))))))
+	
+	  (if (not (= j imax))
+	      (begin
+		(do ((k 0 (+ k 1)))
+		    ((>= k n))
+		  (let ((temp (array-ref a imax k)))
+		    (array-set! a (array-ref a j k) imax k)
+		    (array-set! a temp j k)))
+		(set! sign (- sign))
+		(vector-set! vv imax (vector-ref vv j))))
+	  
+	  (vector-set! indx j imax)
+	  
+	  (if (= (array-ref a j j) 0.0)
+	      (array-set! a *lu-decomposition-epsilon* j j))
+	  
+	  (if (not (= j (- n 1)))
+	      (let ((temp (/ (array-ref a j j))))
+		(do ((i (+ j 1) (+ i 1)))
+		    ((>= i n))
+		  (array-set! a (* (array-ref a i j) temp) i j)))))))
+      
+      (values indx sign)))
+
+(define (lu-back-substitute a indx b)
+  (let ((n (car (array-shape a))))
+	  
+    (let loop ((i 0) (ii #f))
+      (if (< i n)
+	  (let* ((ip (vector-ref indx i))
+		 (temp (vector-ref b ip)))
+	    (vector-set! b ip (vector-ref b i))
+	    (let ((new (if ii
+			   (do ((j ii (+ j 1))
+				(sum temp (- sum (* (array-ref a i j)
+						    (vector-ref b j)))))
+			       ((>= j i)
+				sum))
+			   temp)))
+	      (vector-set! b i new)
+	      (loop (+ i 1)
+		    (if (or ii (= temp 0.0)) ii i))))))
+
+    (do ((i (- n 1) (- i 1)))
+	((< i 0))
+      (do ((j (+ i 1) (+ j 1))
+	   (sum (vector-ref b i) (- sum (* (array-ref a i j)
+					   (vector-ref b j)))))
+	  ((>= j n)
+	   (vector-set! b i (/ sum (array-ref a i i))))))))
+
+;(define m
+;  (array '(4 4)
+;         1.0  2.0 3.0 -2.0
+;         8.0 -6.0 6.0  1.0
+;         3.0 -2.0 0.0 -7.0
+;         4.0  7.0 2.0 -1.0))
+;
+;(define b '#(2.0 1.0 3.0 -2.0))
+;
+;(define (test m b)
+;  (let* ((a (copy-array m))
+;         (n (car (array-shape m)))
+;         (x (make-vector n)))
+;
+;    (do ((i 0 (+ i 1)))
+;        ((>= i n))
+;      (vector-set! x i (vector-ref b i)))
+;
+;    (display "b = ")
+;    (display b)
+;    (newline)
+;
+;    (call-with-values
+;     (lambda ()
+;       (lu-decomposition a))
+;     (lambda (indx sign)
+;       (lu-back-substitute a indx x)
+;
+;       (display "x = ")
+;       (display x)
+;       (newline)
+;
+;       (let ((y (make-vector (vector-length b))))
+;         (do ((i 0 (+ i 1)))
+;             ((>= i n))
+;           (do ((j 0 (+ j 1))
+;                (t 0.0 (+ t (* (array-ref m i j) (vector-ref x j)))))
+;               ((>= j n)
+;                (vector-set! y i t))))
+;
+;         (display "a * x =")
+;         (display y)
+;         (newline))))))
diff --git a/scheme/big/more-port.scm b/scheme/big/more-port.scm
new file mode 100644
index 0000000..4288123
--- /dev/null
+++ b/scheme/big/more-port.scm
@@ -0,0 +1,329 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Additional port types
+
+;----------------
+; Ports which keep track of the current row and column.
+;
+; When the row or column data is requested we need to process the characters
+; between the port's current index and the index at the time of the previous
+; check.
+;
+; When a buffer operation is requested we need to process any remaining
+; characters in the old buffer.  If the operation is a block read or write
+; we also need to process whatever is read or written.
+;
+; port:        the tracking port - needed for its buffer and indicies
+; sub-port:    port being tracked
+; index:       the index of the next character to be processed
+; row, column: position of the character at BUFFER[INDEX - 1] 
+
+(define-record-type port-location :port-location
+  (really-make-port-location sub-port index row column)
+  port-location?
+  (port     port-location-port set-port-location-port!) ; setter for circularity
+  (sub-port port-location-sub-port)
+  (index    port-location-index  set-port-location-index!)
+  (row      port-location-row    set-port-location-row!)
+  (column   port-location-column set-port-location-column!))
+
+(define (make-port-location sub-port)
+  (really-make-port-location sub-port (port-index sub-port) 0 0))
+
+; Update the data and return what you get.
+
+(define (current-row port)
+  (let ((data (port-data port)))
+    (if (port-location? data)
+	(begin
+	  (obtain-port-lock port)
+	  (update-row-and-column! data)
+	  (let ((row (port-location-row data)))
+	    (release-port-lock port)
+	    row))
+	#f)))
+
+(define (current-column port)
+  (let ((data (port-data port)))
+    (if (port-location? data)
+	(begin
+	  (obtain-port-lock port)
+	  (update-row-and-column! data)
+	  (let ((column (port-location-column data)))
+	    (release-port-lock port)
+	    column))
+	#f)))
+
+; Bring LOCATION up to date.
+
+(define (update-row-and-column! location)
+  (let ((at (port-index (port-location-port location)))
+	(checked-to (port-location-index location))
+	(buffer (port-buffer (port-location-port location))))
+    (if (< checked-to at)
+	(begin
+	  (update-row-and-column-from-bytes! buffer checked-to at location)
+	  (set-port-location-index! location at)))))
+
+; Two nearly identical procedures to deal with code-vectors and strings.
+
+(define (update-row-and-column-from-bytes! code-vec start end location)
+  (let loop ((i start)
+	     (row (port-location-row location))
+	     (column (port-location-column location)))
+    (cond ((= i end)
+	   (set-port-location-row! location row)
+	   (set-port-location-column! location column))
+	  ((= (char->ascii #\newline) (code-vector-ref code-vec i))
+	   (loop (+ i 1) (+ row 1) 0))
+	  (else
+	   (loop (+ i 1) row (+ column 1))))))
+
+(define (update-row-and-column-from-chars! string start count location)
+  (let loop ((i start)
+	     (row (port-location-row location))
+	     (column (port-location-column location)))
+    (cond ((= i (+ start count))
+	   (set-port-location-row! location row)
+	   (set-port-location-column! location column))
+	  ((char=? #\newline (string-ref string i))
+	   (loop (+ i 1) (+ row 1) 0))
+	  (else
+	   (loop (+ i 1) row (+ column 1))))))
+
+;----------------
+; Input ports that keep track of the current row and column.
+
+(define tracking-input-port-handler
+  (make-port-handler
+   (lambda (location)
+     (list 'tracking-port (port-location-sub-port location)))
+   (lambda (location)  ; nothing to do
+     (values))
+   (lambda (location buffer start needed)
+     (update-row-and-column! location)  ; finish off old buffer
+     (let ((res (read-block buffer start needed
+			    (port-location-sub-port location))))
+       (cond ((eof-object? res))
+	     ((eq? buffer (port-buffer (port-location-port location)))
+	      (set-port-location-index! location 0))
+	     ((code-vector? buffer)
+	      (update-row-and-column-from-bytes! buffer start res location))
+	     (else
+	      (update-row-and-column-from-chars! buffer start res location)))
+       res))))
+
+(define (make-tracking-input-port port)
+  (if (input-port? port)
+      (let ((new-port (make-input-port tracking-input-port-handler
+				       (make-port-location port)
+				       (make-code-vector default-buffer-size 0)
+				       0
+				       0)))
+	; make the circular link
+	(set-port-location-port! (port-data new-port) new-port)
+	new-port)
+      (call-error "not an input port" make-tracking-input-port port)))
+
+;----------------
+; Output ports that keep track of the current row and column.
+
+(define tracking-output-port-handler
+  (make-port-handler
+   (lambda (location)
+     (list 'tracking-port (port-location-sub-port location)))
+   ; flush the buffer when closing
+   (lambda (location)
+     (let ((port (port-location-port location)))
+       (if (< 0 (port-index port))
+	   (write-block (port-buffer port) 0 (port-index port)
+			(port-location-sub-port location)))))
+   ; Finish off the old buffer, send the characters to the child port, and
+   ; then update the row and column if necessary.
+   (lambda (location buffer start count)
+     (update-row-and-column! location)
+     (write-block buffer start count (port-location-sub-port location))
+     (cond ((eq? buffer (port-buffer (port-location-port location)))
+	    (set-port-location-index! location 0))
+	   ((code-vector? buffer)
+	    (update-row-and-column-from-bytes! buffer start count location))
+	   (else
+	    (update-row-and-column-from-chars! buffer start count location))))))
+
+(define (make-tracking-output-port port)
+  (if (output-port? port)
+      (let ((new-port (make-output-port tracking-output-port-handler
+					(make-port-location port)
+					(make-code-vector default-buffer-size 0)
+					0
+					default-buffer-size)))
+	; make the circular link
+	(set-port-location-port! (port-data new-port) new-port)
+	new-port)
+      (call-error "not an output port" make-tracking-output-port port)))
+
+(define (fresh-line port)
+  (let ((column (current-column port)))
+    (if (and column (< 0 column))
+	(newline port))))
+
+;----------------
+; String input ports
+
+; All the work is done by the port code.
+
+(define string-input-port-handler
+  (make-port-handler
+   (lambda (ignore)
+     (list 'string-input-port))
+   (lambda (ignore)
+     (values))
+   (lambda (ignore buffer start needed)
+     (eof-object))))
+
+(define (make-string-input-port string)
+  (let ((buffer (make-code-vector (string-length string) 0)))
+    (copy-bytes! string 0 buffer 0 (string-length string))
+    (make-input-port string-input-port-handler
+		     #f                          ; no additional state needed
+		     buffer
+		     0
+		     (string-length string))))   ; number of bytes available
+
+(define copy-bytes! (structure-ref primitives copy-bytes!))
+
+;----------------
+; String output ports
+
+; The data field of the port is a list of (<buffer> . <char-count>) pairs
+; (the car is the port itself).  When the output is wanted the buffers are
+; concatenated together to get the final string.
+
+(define buffer-size 1024)
+
+; Concatenates all of the buffers into single string.
+
+(define (string-output-port-output port)
+  (let* ((full (cdr (port-data port)))
+	 (last (port-buffer port))
+	 (index (port-index port))
+	 (count (apply + index (map cdr full)))  ; Scheme is a trip
+	 (out (make-string count)))
+    (let loop ((full (reverse full)) (i 0))
+      (if (null? full)
+	  (copy-bytes! last 0 out i index)
+	  (let ((buffer (caar full))
+		(count (cdar full)))
+	    (copy-bytes! buffer 0 out i count)
+	    (loop (cdr full) (+ i count)))))
+    out))
+
+(define string-output-port-handler
+  (make-port-handler
+   (lambda (port)
+     '(string-output-port))
+   (lambda (port)
+     (values))
+   (lambda (data thing start count)
+     (let ((port (car data)))
+       (set-cdr! (port-data port)
+		 (cons (cons (full-buffer port thing start count)
+			     count)
+		       (cdr (port-data port))))))))
+
+(define (full-buffer port thing start count)
+  (cond ((eq? thing (port-buffer port))
+	 (set-port-buffer! port (make-code-vector default-buffer-size 0))
+	 thing)
+	(else
+	 (let ((b (make-code-vector count 0)))
+	   (copy-bytes! thing start b 0 count)
+	   b))))
+
+(define (make-string-output-port)
+  (let ((port (make-output-port string-output-port-handler
+				(list #f)
+				(make-code-vector default-buffer-size 0)
+				0
+				default-buffer-size)))
+    (set-car! (port-data port) port)
+    port))
+
+(define (call-with-string-output-port proc)
+  (let ((port (make-string-output-port)))
+    (proc port)
+    (string-output-port-output port)))
+
+;----------------
+; Output ports from single character consumers
+
+(define char-sink-output-port-handler
+  (make-port-handler
+   (lambda (proc)
+     (list 'char-sink-output-port))
+   (lambda (proc)
+     (values))
+   (lambda (proc char)
+     (proc char))))
+
+(define (char-sink->output-port proc)
+  (make-unbuffered-output-port char-sink-output-port-handler
+			       proc))
+
+; Call PROC on a port that will transfer COUNT characters to PORT and
+; then quit.
+
+(define (write-one-line port count proc)
+  (call-with-current-continuation
+    (lambda (quit)
+      (proc (char-sink->output-port
+	     (lambda (char)
+	       (write-char char port)
+	       (set! count (- count 1))
+	       (if (<= count 0)
+		   (quit #f))))))))
+
+;----------------
+; Input ports from single character producers
+; The producer is passed #T if a character is needed and #F if not.
+; If #F is passed and no character is ready, then #F is returned.
+
+(define char-source-input-port-handler
+  (make-port-handler
+   (lambda (proc)
+     (list 'char-source-input-port))
+   (lambda (proc)			; nothing to do
+     (values))
+   (lambda (proc buffer start needed)
+     (if (integer? needed)
+	 (let loop ((got 0))
+	   (if (= got needed)
+	       got
+	       (let ((next (proc #t)))
+		 (cond ((char? next)
+			(buffer-set! buffer (+ start got) next)
+			(loop (+ got 1)))
+		       ((= got 0)
+			(eof-object))
+		       (else
+			got)))))
+	 (let ((next (proc (eq? needed 'any))))
+	   (cond ((not next)
+		  0)
+		 ((eof-object? next)
+		  (eof-object))
+		 (else
+		  (buffer-set! buffer start next)
+		  1)))))))
+
+(define (buffer-set! buffer index char)
+  (if (string? buffer)
+      (string-set! buffer index char)
+      (code-vector-set! buffer index (char->ascii char))))
+
+(define (char-source->input-port proc)
+  (make-input-port char-source-input-port-handler
+		   proc
+		   (make-code-vector 1 0)
+		   0
+		   0))
diff --git a/scheme/big/pipe.scm b/scheme/big/pipe.scm
new file mode 100644
index 0000000..79a38e3
--- /dev/null
+++ b/scheme/big/pipe.scm
@@ -0,0 +1,413 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Pipes.
+;
+; This would be easy except that we have to deal with threads (and who else
+; would be using pipes?).
+;
+; Pipes either have a fixed set of buffers which are continually recycled or
+; create new buffers as needed.  Having a fixed buffer supply keeps readers
+; and writers more-or-less synchronised, while creating buffers as needed allows
+; the writers to get arbitrarily far ahead of the readers.
+;
+; A fixed-buffer pipe has two buffers.  At any point one is acting as the
+; input buffer and the other as the output buffer.  When the input buffer is
+; empty the two are swapped.
+;
+; The complexity of the code below comes from having to deal with the two
+; blocking situations:
+;  - a read is done when all buffers are empty
+;  - a write is done when the output buffer is full and the input buffer
+;    is non-empty (and we aren't allowed to make more buffers)
+; 
+; If a read occurs when all buffers are empty we swap a zero-length buffer in
+; for the output-buffer and block on a condition variable.  The zero-length
+; buffer guarantees that the reading thread will be woken when the next write
+; occurs.  When a write occurs with a zero-length buffer we swap in the real
+; buffer, do the write, and then set the input condition variable.
+;
+; When a write occurs with the write buffer full for a pipe without a fixed
+; set of buffers the full buffer is added to a queue.
+;
+; For a pipe with only two buffers, if a write occurs with the write buffer
+; full and the read buffer non-empty, we set the read-limit to be one shorter
+; than its real value and block on a condition variable.  The bogus read-limit
+; means that the writing thread will be woken when a read empties the buffer
+; and not have to wait until the following read.  When a read reaches the
+; read-limit we check to see if there are waiting output threads.  If so, we
+; write one more character and then wake the sleepers.
+;
+; If this were a little more integrated with the threads package pipes
+; could use queues instead of making new condition variables all the time.
+
+(define-record-type pipe-data :pipe-data
+  (make-pipe-data lock in-condvar out-condvar queue out-buffer)
+  pipe-data?
+  (lock pipe-lock)   ; a lock for keeping this pipe single threaded
+  (in-condvar        ; waiting for a non-empty buffer
+   pipe-in-condvar
+   set-pipe-in-condvar!)
+  (out-condvar       ; waiting for an empty buffer
+   pipe-out-condvar
+   set-pipe-out-condvar!)
+  (queue             ; queue of full buffers, or #f for a pipe with a fixed
+   pipe-buffer-queue);   buffer set
+  (out-buffer        ; stashed output buffer
+   pipe-out-buffer
+   set-pipe-out-buffer!))
+    
+(define (lock pipe)
+  (obtain-lock (pipe-lock (port-data pipe))))
+
+(define (unlock pipe)
+  (release-lock (pipe-lock (port-data pipe))))
+
+; Swap the buffers and initialize the various buffer pointers.
+
+(define (swap-buffers! port)
+  (let ((temp (port-in-buffer port)))
+    (set-port-in-buffer! port (port-out-buffer port))
+    (set-port-out-buffer! port temp)
+    (set-port-in-limit! port (port-out-index port))
+    (set-port-in-index! port 0)
+    (set-port-out-index! port 0)))
+
+; Get a full buffer from the queue.
+
+(define (use-buffer-from-queue port)
+  (let ((queue (pipe-buffer-queue (port-data port))))
+    (if (and queue (not (queue-empty? queue)))
+	(let ((buffer (dequeue! queue)))
+	  (set-port-in-buffer! port buffer)
+	  (set-port-in-index! port 0)
+	  (set-port-in-limit! port (code-vector-length buffer))
+	  #t)
+	#f)))
+
+;----------------------------------------------------------------
+; Input buffers
+
+; Get a non-empty input buffer, if possible.  We have five options:
+;  1. The current buffer isn't empty.
+;  2. The current buffer looks empty but really isn't; the limit was
+;     decremented by a writer who wants an empty buffer.
+;  3. There is a queue and it has a full buffer.
+;  4. The output buffer isn't empty.
+;  5. The output port is still open and may produce characters in the future.
+; If there are no characters and the output port is closed we lose.
+
+(define (get-in-buffer port)
+  (cond ((> (port-in-limit port)
+	    (port-in-index port))
+	 #t)
+	((pipe-out-condvar (port-data port))
+	 (set-port-in-limit! port (+ 1 (port-in-limit port)))
+	 #t)
+	((use-buffer-from-queue port)
+	 #t)
+	((< 0 (port-out-index port))
+	 (swap-buffers! port)
+	 #t)
+	((open-output-port? port)
+	 (wait-for-input port)
+	 (get-in-buffer port))
+	(else
+	 #f)))
+
+; Wait on the input condition variable.  If there isn't one, we make a
+; new condition variable and swap in a zero-length write buffer to get the
+; condition variable set as soon as a write occurs.
+
+(define (wait-for-input port)
+  (let* ((data (port-data port))
+	 (cv (if (pipe-in-condvar data)
+		 (pipe-in-condvar data)
+		 (let ((cv (make-condvar)))
+		   (set-pipe-out-buffer! (port-data port) (port-out-buffer port))
+		   (set-port-out-buffer! port (make-code-vector 0 0))
+		   (set-pipe-in-condvar! data cv)
+		   cv))))
+    (release-lock (pipe-lock data))
+    (condvar-ref cv)
+    (obtain-lock (pipe-lock data))))
+
+; Wake any threads waiting for input if there are characters available.
+
+(define (wake-any-input-waiters port)
+  (let ((data (port-data port)))
+    (let ((cv (pipe-in-condvar data)))
+      (if (and cv
+	       (or (< 0 (port-out-index port))
+		   (not (open-output-port? port))))
+	  (begin
+            (set-pipe-in-condvar! data #f)
+	    (condvar-set! cv (unspecific)))))))
+
+;----------------------------------------------------------------
+; Output buffers
+
+; Get a non-full output buffer, if possible.  We have five options:
+;  1. The current buffer has room.
+;  2. The current buffer looks full but really isn't; it is a zero-length
+;     buffer swapped in by a reader who wants characters.
+;  3. There is a queue for full buffers.
+;  4. The input buffer is empty.
+;  5. The input port is still open and may empty its buffer later on.
+; If there are no empty buffers and the input port is closed we lose.
+
+(define (get-out-buffer port)
+  (let ((len (code-vector-length (port-out-buffer port))))
+    (cond ((< (port-out-index port) len)
+           #t)
+	  ((= 0 len)
+	   (set-port-out-buffer! port (pipe-out-buffer (port-data port)))
+	   #t)
+	  ((pipe-buffer-queue (port-data port))
+	   (make-new-out-buffer port)
+	   #t)
+	  ((= (port-in-index port) (port-in-limit port))
+           (swap-buffers! port)
+	   #t)
+	  ((open-input-port? port)
+	   (wait-for-output port)
+	   (get-out-buffer port))
+	  (else
+	   #f))))
+
+; Make a new output buffer and put the full one on the queue.
+
+(define (make-new-out-buffer port)
+  (let* ((old (port-out-buffer port))
+	 (new (make-code-vector (code-vector-length old) 0)))
+    (enqueue! (pipe-buffer-queue (port-data port)) old)
+    (set-port-out-buffer! port new)
+    (set-port-out-index! port 0)))
+
+; Same as above, on a different condition variable and with a different
+; wakeup method.
+
+(define (wait-for-output port)
+  (let* ((data (port-data port))
+	 (cv (if (pipe-out-condvar data)
+                 (pipe-out-condvar data)
+                 (let ((cv (make-condvar)))
+		   (set-port-in-limit! port (- (port-in-limit port) 1))
+		   (set-pipe-out-condvar! data cv)
+		   cv))))
+    (release-lock (pipe-lock data))
+    (condvar-ref cv)
+    (obtain-lock (pipe-lock data))))
+
+(define (wake-any-output-waiters port)
+  (let ((data (port-data port)))
+    (let ((cv (pipe-out-condvar data)))
+      (if (and cv
+	       (or (= (port-in-limit port) (port-in-index port))
+		   (not (open-output-port? port))))
+	  (begin
+            (set-pipe-out-condvar! data #f)
+	    (condvar-set! cv (unspecific)))))))
+
+; Used by PEEK-CHAR to reset the wakeup limit.
+
+(define (do-not-disturb-output-waiters port)
+  (if (pipe-out-condvar (port-data port))
+      (set-port-in-limit! port (- (port-in-limit port) 1))))
+
+; Close both ports and wake up any sleepers.
+
+(define (close-pipe port close-input?)
+  (lock port)
+  (if close-input? 
+      (make-input-port-closed! port))
+  (make-output-port-closed! port)
+  (wake-any-input-waiters port)
+  (wake-any-output-waiters port)
+  (unlock port))
+
+;----------------------------------------------------------------
+; The actual handler
+
+(define pipe-handler
+  (make-port-handler
+
+   ;; discloser
+   (lambda (port)
+     (list 'pipe))
+
+   ;; input port methods --------------------------
+
+   ;; close-input-port
+   (lambda (port)
+     (close-pipe port #t))
+
+   ;; The next three methods are called when the input buffer is empty
+   ;; read-char
+   (lambda (port)
+     (lock port)
+     (cond ((get-in-buffer port)
+	    (let ((c (read-char port)))
+	      (wake-any-output-waiters port)
+	      (unlock port)
+	      c))
+	   (else
+            (unlock port)
+	    (eof-object))))
+
+   ;; peek-char
+   (lambda (port)
+     (lock port)
+     (cond ((get-in-buffer port)
+	    (let ((c (peek-char port)))
+	      (do-not-disturb-output-waiters port)
+	      (unlock port)
+	      c))
+	   (else
+            (unlock port)
+	    (eof-object))))
+
+   ;; char-ready?
+   (lambda (port)
+     (> (port-out-index port) 0))
+
+   ;; read-block - the buffer has fewer than COUNT characters
+   (lambda (thing start count port)
+     (lock port)
+     (let loop ((start start) (count count))
+       (let* ((index (port-in-index port))
+	      (have (min (- (port-in-limit port) index)
+			 count)))
+	 (cond ((> have 0)
+		(copy! (port-in-buffer port) index thing start have)
+		(set-port-in-index! port (+ index have))))
+	 (wake-any-output-waiters port)
+	 (cond ((= have count)
+		(unlock port))
+	       ((get-in-buffer port)
+                (loop (+ start have) (- count have)))
+	       (else
+		(unlock port)
+		(eof-object))))))
+
+   ;; output port methods -------------------------
+
+   ;; close-output-port
+   (lambda (port)
+     (close-pipe port #f))
+
+   ;; write-char got a full buffer
+   (lambda (char port)
+     (lock port)
+     (cond ((get-out-buffer port)
+	    (write-char char port)
+	    (wake-any-input-waiters port)
+	    (unlock port))
+	   (else
+            (unlock port)
+	    (error "writing to a broken pipe"))))
+
+   ;; write-block couldn't fit COUNT characters into the buffer
+   (lambda (thing start count port)
+     (lock port)
+     (let loop ((start start) (count count))
+       (cond ((get-out-buffer port)
+	      (let* ((buffer (port-out-buffer port))
+		     (index (port-out-index port))
+		     (have (min (- (code-vector-length buffer) index)
+				count)))
+                (cond ((> have 0)
+		       (copy! thing start buffer index have)
+		       (set-port-out-index! port (+ index have))))
+		(wake-any-input-waiters port)
+		(if (= have count)
+		    (unlock port)
+		    (loop (+ start have) (- count have)))))
+	     (else
+	      (unlock port)
+	      (error "writing to a broken pipe")))))
+
+   ;; force-output
+   (lambda (port)
+     (values))))
+
+(define pipe-buffer-size 1024)
+
+; Takes an optional size to use for the buffers.  A size of #f indicates
+; that buffers should be made as needed (we really need omega).
+
+(define (make-pipe . maybe-buffer-size)
+  (call-with-values
+   (lambda ()
+     (parse-make-pipe-args maybe-buffer-size))
+   (lambda (size queue)
+     (make-port pipe-handler
+		(bitwise-ior open-input-port-status
+			     open-output-port-status)
+		(make-pipe-data (make-lock) ; the lock
+				#f	    ; input condition variable
+				#f	    ; output condition variable
+				queue       ; full buffer queue
+				#f)	    ; stashed output buffer
+		(make-code-vector size 0)   ; input buffer
+		0			    ; input index
+		0			    ; input limit
+		(make-code-vector size 0)   ; output buffer
+		0))))			    ; output limit
+  
+(define (parse-make-pipe-args maybe-buffer-size)
+  (if (null? maybe-buffer-size)
+      (values pipe-buffer-size #f)
+      (let ((size (car maybe-buffer-size)))
+	(cond ((not size)
+	       (values pipe-buffer-size (make-queue)))
+	      ((and (integer? size)
+		    (exact? size)
+		    (< 0 size))
+	       (values size #f))
+	      (else
+	       (call-error "invalid pipe buffer size" make-pipe size))))))
+
+; These should probably be moved to I/O
+
+(define (open-input-port? port)
+  (= (bitwise-and open-input-port-status
+		  (port-status port))
+     open-input-port-status))
+
+(define (open-output-port? port)
+  (= (bitwise-and open-output-port-status
+		  (port-status port))
+     open-output-port-status))
+
+; Won't do string->string copies.
+
+(define (copy! from i to j count)
+  (if (code-vector? from)
+      (if (code-vector? to)
+	  (copy-bytes! from i to j count)
+	  (copy-bytes->chars! from i to j count))
+      (copy-chars->bytes! from i to j count)))
+
+; Copied from more-port.scm.
+
+(define (copy-bytes! from i to j count)
+  (let ((limit (+ count i)))
+    (do ((i i (+ i 1))
+	 (j j (+ j 1)))
+	((= i limit))
+      (code-vector-set! to j (code-vector-ref from i)))))
+
+(define (copy-chars->bytes! from i to j count)
+  (let ((limit (+ count i)))
+    (do ((i i (+ i 1))
+	 (j j (+ j 1)))
+	((= i limit))
+      (code-vector-set! to j (char->ascii (string-ref from i))))))
+
+(define (copy-bytes->chars! from i to j count)
+  (let ((limit (+ count i)))
+    (do ((i i (+ i 1))
+	 (j j (+ j 1)))
+	((= i limit))
+      (string-set! to j (ascii->char (code-vector-ref from i))))))
+
diff --git a/scheme/big/placeholder.scm b/scheme/big/placeholder.scm
new file mode 100644
index 0000000..5b4d275
--- /dev/null
+++ b/scheme/big/placeholder.scm
@@ -0,0 +1,49 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+; Placeholders (single-assignment cells for use with threads)
+
+(define-record-type placeholder :placeholder
+  (really-make-placeholder queue id)
+  placeholder?
+  (queue placeholder-queue set-placeholder-queue!) ; #f means VALUE has been set
+  (value placeholder-real-value set-placeholder-value!)
+  (id placeholder-id))
+
+(define-record-discloser :placeholder
+  (lambda (placeholder)
+    (cons 'placeholder
+	  (if (placeholder-id placeholder)
+	      (list (placeholder-id placeholder))
+	      '()))))
+
+(define (make-placeholder . id-option)
+  (really-make-placeholder (make-thread-queue)
+			   (if (null? id-option) #f (car id-option))))
+
+(define (placeholder-value placeholder)
+  (with-interrupts-inhibited
+   (lambda ()
+     (if  (placeholder-queue placeholder)
+	  (begin
+	    (enqueue-thread! (placeholder-queue placeholder)
+			     (current-thread))
+	    (block)))
+     (placeholder-real-value placeholder))))
+
+(define (placeholder-set! placeholder value)
+  (let ((waiters (with-interrupts-inhibited
+		  (lambda ()
+		    (let ((queue (placeholder-queue placeholder)))
+		      (cond (queue
+			     (set-placeholder-value! placeholder value)
+			     (set-placeholder-queue! placeholder #f)
+			     (do ((waiters '() (cons (dequeue-thread! queue)
+						     waiters)))
+				 ((thread-queue-empty? queue)
+				  waiters)))
+			    (else #f)))))))
+    (if waiters
+	(for-each make-ready waiters)
+	(if (not (eq? value (placeholder-value placeholder)))
+	    (error "placeholder is already assigned"
+		   placeholder
+		   value)))))
diff --git a/scheme/big/pp.scm b/scheme/big/pp.scm
new file mode 100644
index 0000000..e6c2f27
--- /dev/null
+++ b/scheme/big/pp.scm
@@ -0,0 +1,431 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+;;;; A pretty-printer
+
+; This isn't exactly in the spirit of the rest of the Scheme 48
+; system.  It's too hairy, and it has unexploited internal generality.
+; It really ought to be rewritten.  In addition, it seems to be buggy
+; -- it sometimes prints unnecessarily wide lines.  Usually it's
+; better than no pretty printer at all, so we tolerate it.
+
+; From: ramsdell@linus.mitre.org
+; Date:  Wed, 12 Sep 1990 05:14:49 PDT
+;
+; As you noted in your comments, pp.scm is not a straight forward
+; program.  You could add some comments that would greatly ease the task
+; of figuring out what his going on.  In particular, you should describe
+; the interface of various objects---most importantly the interface of a
+; formatter.  You might also add some description as to what protocol
+; they are to follow.
+
+; Other things to implement some day:
+;  - LET, LET*, LETREC binding lists should be printed vertically if longer
+;    than about 30 characters
+;  - COND clauses should all be printed vertically if the COND is vertical
+;  - Add an option to lowercase or uppercase symbols and named characters.
+;  - Parameters controlling behavior of printer should be passed around
+;  - Do something about choosing between #f and ()
+;  - Insert line breaks intelligently following head of symbol-headed list,
+;    when necessary
+;  - Some equivalents of *print-level*, *print-length*, *print-circle*.
+
+; Possible strategies:
+;   (foo x y z)     Horizontal = infinity sticky 
+;   (foo x y        One sticky + one + body (e.g. named LET)
+;     z
+;     w)
+;   (foo x          One + body
+;     y
+;     z)
+;   (foo x          Two + body
+;        y
+;     z)
+;   (foo x          Big ell = infinity + body (combination)
+;	 y
+;	 z)
+;   (foo            Little ell, zero + body (combination)
+;     x
+;     y)
+;   (foo            Vertical
+;    x
+;    y)
+;
+; Available height/width tradeoffs:
+;   Combination:
+;     Horizontal, big ell, or little ell.
+;   Special form:
+;     Horizontal, or M sticky + N + body.
+;   Random (e.g. vector, improper list, non-symbol-headed list):
+;     Horizontal, or vertical.  (Never zero plus body.)
+
+(define (p x . port-option)
+  (let ((port (if (pair? port-option) (car port-option)
+		  (current-output-port))))
+    (pretty-print x port 0)
+    (newline port)))
+
+(define *line-width* 80)
+
+(define *single-line-special-form-limit* 30)
+
+; Stream primitives
+
+(define head car)
+(define (tail s) (force (cdr s)))
+
+(define (map-stream proc stream)
+  (cons (proc (head stream))
+	(delay (map-stream proc (tail stream)))))
+
+(define (stream-ref stream n)
+  (if (= n 0)
+      (head stream)
+      (stream-ref (tail stream) (- n 1))))
+
+; Printer
+
+(define (pretty-print obj port pos)
+  (let ((node (pp-prescan obj 0)))
+;    (if (> (column-of (node-dimensions node)) *line-width*)
+;        ;; Eventually add a pass to change format of selected combinations
+;        ;; from big-ell to little-ell.
+;        (begin (display ";** too wide - ")
+;               (write (node-dimensions node))
+;               (newline)))
+    (print-node node port pos)))
+
+(define make-node list)
+
+(define (node-dimensions node)
+  ((car node)))
+
+(define (node-pass-2 node pos)
+  ((cadr node) pos))
+
+(define (print-node node port pos)
+  ((caddr node) port pos))
+
+(define (pp-prescan obj hang)
+  (cond ((symbol? obj)
+         (make-leaf (string-length (symbol->string obj))
+                    obj hang))
+        ((number? obj)
+         (make-leaf (string-length (number->string obj))
+                    obj hang))
+        ((boolean? obj)
+         (make-leaf 2 obj hang))
+        ((string? obj)
+         ;;++ Should count number of backslashes and quotes
+         (make-leaf (+ (string-length obj) 2) obj hang))
+        ((char? obj)
+         (make-leaf (case obj
+                      ((#\space) 7)
+                      ((#\newline) 9)
+                      (else 3))
+                    obj hang))
+        ((pair? obj)
+         (pp-prescan-pair obj hang))
+        ((vector? obj)
+         (pp-prescan-vector obj hang))
+	(else
+	 (pp-prescan-random obj hang))))
+
+(define (make-leaf width obj hang)
+  (let ((width (+ width hang)))
+    (make-node (lambda () width)
+	       (lambda (pos)
+		 (+ pos width))
+	       (lambda (port pos)
+		 (write obj port)
+		 (do ((i 0 (+ i 1)))
+		     ((>= i hang) (+ pos width))
+		   (write-char #\) port))))))
+
+(define (make-prefix-node string node)
+  (let ((len (string-length string)))
+    (make-node (lambda ()
+		 (+ (node-dimensions node) len))
+	       (lambda (pos)
+		 (node-pass-2 node (+ pos len)))
+	       (lambda (port pos)
+		 (display string port)
+		 (print-node node port (+ pos len))))))
+
+(define (pp-prescan-vector obj hang)
+  (if (= (vector-length obj) 0)
+      (make-leaf 3 obj hang)
+      (make-prefix-node "#" (pp-prescan-list (vector->list obj) #t hang))))
+
+; Improve later.
+
+(define (pp-prescan-random obj hang)
+  (let ((l (disclose obj)))
+    (if (list? l)
+	(make-prefix-node "#." (pp-prescan-list l #t hang))
+	(make-leaf 25 obj hang))))  ;Very random number
+
+(define (pp-prescan-pair obj hang)
+  (cond ((read-macro-inverse obj)
+         =>
+         (lambda (inverse)
+	   (make-prefix-node inverse (pp-prescan (cadr obj) hang))))
+        (else
+         (pp-prescan-list obj #f hang))))
+
+(define (pp-prescan-list obj random? hang)
+  (let loop ((l obj) (z '()))
+    (if (pair? (cdr l))
+	(loop (cdr l)
+	      (cons (pp-prescan (car l) 0) z))
+	(make-list-node
+	  (reverse
+	    (if (null? (cdr l))
+		(cons (pp-prescan (car l) (+ hang 1)) z)
+		(cons (make-prefix-node ". " (pp-prescan (cdr l) (+ hang 1)))
+		      (cons (pp-prescan (car l) 0) z))))
+	  obj
+	  (or random? (not (null? (cdr l))))))))
+
+; Is it sufficient to tell parent node:
+;  At a cost of X line breaks, I can make myself narrower by Y columns. ?
+; Then how do we decide whether we narrow ourselves or some of our children?
+
+(define (make-list-node node-list obj random?)
+  (let* ((random? (or random?
+		      ;; Heuristic for things like do, cond, let, ...
+		      (not (symbol? (car obj)))
+		      (eq? (car obj) 'else)))
+	 (probe (if (not random?)
+		    (indentation-for (car obj))
+		    #f))
+	 (format horizontal-format)
+	 (dimensions (compute-dimensions node-list format))
+	 (go-non-horizontal
+	  (lambda (col)
+	    (set! format
+		  (cond (random? vertical-format)
+			(probe (probe obj))
+			(else big-ell-format)))
+	    (let* ((start-col (+ col 1))
+		   (col (node-pass-2 (car node-list) start-col))
+		   (final-col
+		       (format (cdr node-list) 
+			       (lambda (node col target-col)
+				 (node-pass-2 node target-col))
+			       start-col
+			       (+ col 1)
+			       col)))
+	      (set! dimensions (compute-dimensions node-list format))
+	      final-col))))
+    (if (> dimensions
+	   (if probe
+	       *single-line-special-form-limit*
+	       *line-width*))
+	(go-non-horizontal 0))
+    (make-node (lambda () dimensions)
+	       (lambda (col) ;Pass 2: if necessary, go non-horizontal
+		 (let ((defacto (+ col (column-of dimensions))))
+		   (if (> defacto *line-width*)
+		       (go-non-horizontal col)
+		       defacto)))
+	       (lambda (port pos)
+		 (write-char #\( port)
+		 (let* ((pos (+ pos 1))
+			(start-col (column-of pos))
+			(pos (print-node (car node-list) port pos)))
+		   (format (cdr node-list) 
+			   (lambda (node pos target-col)
+			     (let ((pos (go-to-column target-col
+						      port pos)))
+			       (print-node node port pos)))
+			   start-col
+			   (+ (column-of pos) 1)
+			   pos))))))
+
+(define (compute-dimensions node-list format)
+  (let* ((start-col 1)			;open paren
+	 (pos (+ (make-position start-col 0)
+		 (node-dimensions (car node-list)))))
+    (format (cdr node-list)
+	    (lambda (node pos target-col)
+	      (let* ((dims (node-dimensions node))
+		     (lines (+ (line-of pos) (line-of dims)))
+		     (width (+ target-col (column-of dims))))
+		(if (>= (column-of pos) target-col)
+		    ;; Line break required
+		    (make-position
+		     (max (column-of pos) width)
+		     (+ lines 1))
+		    (make-position width lines))))
+	    start-col
+	    (+ (column-of pos) 1)	;first-col
+	    pos)))
+
+; Three positions are significant
+;   (foo baz ...)
+;    ^   ^  ^
+;    |   |  +--- (column-of pos)
+;    |   +------ first-col
+;    +---------- start-col
+
+; Separators
+
+(define on-same-line
+  (lambda (start-col first-col pos)
+    start-col first-col ;ignored
+    (+ (column-of pos) 1)))
+
+(define indent-under-first
+  (lambda (start-col first-col pos)
+    start-col ;ignored
+    first-col))
+
+(define indent-for-body
+  (lambda (start-col first-col pos)
+    first-col ;ignored
+    (+ start-col 1)))
+
+(define indent-under-head
+  (lambda (start-col first-col pos)
+    first-col ;ignored
+    start-col))
+
+; Format constructors
+
+(define (once separator format)
+  (lambda (tail proc start-col first-col pos)
+    (if (null? tail)
+	pos
+	(let ((target-col (separator start-col first-col pos)))
+	  (format (cdr tail)
+		  proc
+		  start-col
+		  first-col
+		  (proc (car tail) pos target-col))))))
+
+(define (indefinitely separator)
+  (letrec ((self (once separator	;eta
+		       (lambda (tail proc start-col first-col pos)
+			 (self tail proc start-col first-col pos)))))
+    self))
+
+(define (repeatedly separator count format)
+  (do ((i 0 (+ i 1))
+       (format format
+	       (once separator format)))
+      ((>= i count) format)))
+
+; Particular formats
+
+(define vertical-format
+  (indefinitely indent-under-head))
+
+(define horizontal-format
+  (indefinitely on-same-line))
+
+(define big-ell-format
+  (indefinitely indent-under-first))
+
+(define little-ell-format
+  (indefinitely indent-for-body))
+
+(define format-for-named-let
+  (repeatedly on-same-line 2 (indefinitely indent-for-body)))
+
+(define hook-formats
+  (letrec ((stream (cons little-ell-format
+			 (delay (map-stream (lambda (format)
+					      (once indent-under-first format))
+					    stream)))))
+    stream))
+
+; Hooks for special forms.
+; A hook maps an expression to a format.
+
+(define (compute-let-indentation exp)
+  (if (and (not (null? (cdr exp)))
+	   (symbol? (cadr exp)))
+      format-for-named-let
+      (stream-ref hook-formats 1)))
+
+(define hook
+  (let ((hooks (map-stream (lambda (format)
+			     (lambda (exp) exp ;ignored
+			       format))
+			   hook-formats)))
+    (lambda (n)
+      (stream-ref hooks n))))
+
+
+; Table of indent hooks.
+
+(define indentations (make-table))
+
+(define (indentation-for name)
+  (table-ref indentations name))
+
+(define (define-indentation name n)
+  (table-set! indentations
+	      name
+	      (if (integer? n) (hook n) n)))
+
+; Indent hooks for Revised^n Scheme.
+
+(for-each (lambda (name)
+	    (define-indentation name 1))
+	  '(lambda define define-syntax let* letrec let-syntax letrec-syntax
+	    case call-with-values call-with-input-file
+	    call-with-output-file with-input-from-file
+	    with-output-to-file syntax-rules))
+
+(define-indentation 'do            2)
+(define-indentation 'call-with-current-continuation 0)
+
+(define-indentation 'let           compute-let-indentation)
+
+; Kludge to force vertical printing (do AND and OR as well?)
+(define-indentation 'if            (lambda (exp) big-ell-format))
+(define-indentation 'cond          (lambda (exp) big-ell-format))
+
+
+; Other auxiliaries
+
+(define (go-to-column target-col port pos) ;=> pos
+  ;; Writes at least one space or newline
+  (let* ((column (column-of pos))
+	 (line (if (>= column target-col)
+		   (+ (line-of pos) 1)
+		   (line-of pos))))
+    (do ((column (if (>= column target-col)
+		     (begin (newline port) 0)
+		     column)
+		 (+ column 1)))
+	((>= column target-col)
+	 (make-position column line))
+      (write-char #\space port))))
+
+(define (make-position column line)
+  (+ column (* line 1000)))
+
+(define (column-of pos)
+  (remainder pos 1000))
+
+(define (line-of pos)
+  (quotient pos 1000))
+
+(define (read-macro-inverse x)
+  (cond ((and (pair? x)
+              (pair? (cdr x))
+              (null? (cddr x)))
+         (case (car x)
+           ((quote)            "'")
+           ((quasiquote)       "`")
+           ((unquote)          ",")
+           ((unquote-splicing) ",@")
+           (else #f)))
+        (else #f)))
+
+; For the command processor:
+
+;(define-command 'p "<exp>" "pretty-print" '(expression)
+;  (p (eval expression (user-package)) (command-output)))
diff --git a/scheme/big/queue.scm b/scheme/big/queue.scm
new file mode 100644
index 0000000..8730c92
--- /dev/null
+++ b/scheme/big/queue.scm
@@ -0,0 +1,92 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Queues
+; Richard's code with Jonathan's names.
+;
+;     Richard's names:     Jonathan's names (modified by popular demand):
+;      make-empty-queue     make-queue
+;      add-to-queue!	    enqueue!
+;      remove-from-queue!   dequeue!
+
+(define-record-type queue :queue
+  (really-make-queue uid head tail)
+  queue?
+  (uid queue-uid)
+  (head queue-head set-queue-head!)
+  (tail queue-tail set-queue-tail!))
+
+(define *queue-uid* 0)
+
+(define (make-queue)
+  (let ((uid *queue-uid*))
+    (set! *queue-uid* (+ uid 1))	;potential synchronization screw
+    (really-make-queue uid '() '())))
+
+
+; The procedures for manipulating queues.
+
+(define (queue-empty? q)
+  (null? (queue-head q)))
+
+(define (enqueue! q v)
+  (let ((p (cons v '())))
+    (if (null? (queue-head q))	;(queue-empty? q)
+        (set-queue-head! q p)
+        (set-cdr! (queue-tail q) p))
+    (set-queue-tail! q p)))
+
+(define (queue-front q)
+  (if (queue-empty? q)
+      (error "queue is empty" q)
+      (car (queue-head q))))
+
+(define (dequeue! q)
+  (let ((pair (queue-head q)))
+    (cond ((null? pair)	;(queue-empty? q)
+	   (error "empty queue" q))
+	  (else
+	   (let ((value (car pair))
+		 (next  (cdr pair)))
+	     (set-queue-head! q next)
+	     (if (null? next)
+		 (set-queue-tail! q '()))   ; don't retain pointers
+	     value)))))
+
+(define (on-queue? v q)
+  (memq v (queue-head q)))
+
+; This removes the first occurrence of V from Q.
+
+(define (delete-from-queue! q v)
+  (delete-from-queue-if! q (lambda (x) (eq? x v))))
+
+(define (delete-from-queue-if! q pred)
+  (let ((list (queue-head q)))
+    (cond ((null? list)
+	   #f)
+	  ((pred (car list))
+	   (set-queue-head! q (cdr list))
+           (if (null? (cdr list))
+               (set-queue-tail! q '()))   ; don't retain pointers
+	   #t)
+	  ((null? (cdr list))
+	   #f)
+	  (else
+	   (let loop ((list list))
+	     (let ((tail (cdr list)))
+	       (cond ((null? tail)
+		      #f)
+		     ((pred (car tail))
+		      (set-cdr! list (cdr tail))
+		      (if (null? (cdr tail))
+			  (set-queue-tail! q list))
+		      #t)
+		     (else
+		      (loop tail)))))))))
+
+(define (queue->list q)        ;For debugging
+  (map (lambda (x) x)
+       (queue-head q)))
+
+(define (queue-length q)
+  (length (queue-head q)))
diff --git a/scheme/big/random.scm b/scheme/big/random.scm
new file mode 100644
index 0000000..ec026e9
--- /dev/null
+++ b/scheme/big/random.scm
@@ -0,0 +1,61 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Random number generator, extracted from T sources.  Original
+; probably by Richard Kelsey.
+
+; Tests have shown that this is not particularly random.
+
+(define half-log 14)
+(define full-log (* half-log 2))
+(define half-mask (- (arithmetic-shift 1 half-log) 1))
+(define full-mask (- (arithmetic-shift 1 full-log) 1))
+(define index-log 6)
+(define random-1 (bitwise-and 314159265 full-mask))
+(define random-2 (bitwise-and 271828189 full-mask))
+
+; (MAKE-RANDOM <seed>) takes an integer seed and returns a procedure of no
+; arguments that returns a new pseudo-random number each time it is called.
+; <Seed> should be between 0 and 2**28 - 1 (exclusive).
+
+(define (make-random seed)
+  (if (and (integer? seed)
+	   (< 0 seed)
+	   (<= seed full-mask))
+      (make-random-vector seed
+        (lambda (vec a b)
+	  (lambda ()
+	    (set! a (randomize a random-1 random-2))
+	    (set! b (randomize b random-2 random-1))
+	    (let* ((index (arithmetic-shift a (- index-log full-log)))
+		   (c (vector-ref vec index)))
+	      (vector-set! vec index b)
+	      c))))
+      (call-error "invalid argument" make-random seed)))
+
+(define (randomize x mult ad)
+  (bitwise-and (+ (low-bits-of-product x mult) ad)
+               full-mask))
+
+(define (make-random-vector seed return)
+  (let* ((size (arithmetic-shift 1 index-log))
+         (vec (make-vector size 0)))
+    (do ((i 0 (+ i 1))
+         (b seed (randomize b random-2 random-1)))
+        ((>= i size)
+         (return vec seed b))
+      (vector-set! vec i b))))
+
+; Compute low bits of product of two fixnums using only fixnum arithmetic.
+; [x1 x2] * [y1 y2] = [x1y1 (x1y2+x2y1) x2y2]
+
+(define (low-bits-of-product x y)
+  (let ((x1 (arithmetic-shift x (- 0 half-log)))
+        (y1 (arithmetic-shift y (- 0 half-log)))
+        (x2 (bitwise-and x half-mask))
+        (y2 (bitwise-and y half-mask)))
+     (bitwise-and (+ (* x2 y2)
+                     (arithmetic-shift (bitwise-and (+ (* x1 y2) (* x2 y1))
+                                                    half-mask)
+                                       half-log))
+                  full-mask)))
diff --git a/scheme/big/receive.scm b/scheme/big/receive.scm
new file mode 100644
index 0000000..7332091
--- /dev/null
+++ b/scheme/big/receive.scm
@@ -0,0 +1,8 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+(define-syntax receive
+  (syntax-rules ()
+    ((receive ?vars ?producer . ?body)
+     (call-with-values (lambda () ?producer)
+       (lambda ?vars . ?body)))))
diff --git a/scheme/big/search-tree.scm b/scheme/big/search-tree.scm
new file mode 100644
index 0000000..f776682
--- /dev/null
+++ b/scheme/big/search-tree.scm
@@ -0,0 +1,441 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Red-Black binary search trees as described in Introduction to Algorithms
+; by Cormen, Leiserson, and Rivest.  Look there if you want to understand
+; the algorithm.
+;
+; These are like tables in that the value of a key defaults to #f.
+;
+; (make-search-tree key-= key-<)      -> tree
+;
+; (search-tree? value)                -> boolean
+;
+; (search-tree-ref tree key)          -> value
+;
+; (search-tree-set! tree key value)
+;
+; (search-tree-modify! tree key proc)
+;   == (search-tree-set! tree key (proc (search-tree-ref tree key)))
+;
+; (search-tree-max tree)              -> key + value
+; (pop-search-tree-max! tree)         -> key + value  (removes entry)
+;
+; (search-tree-min tree)              -> key + value
+; (pop-search-tree-min! tree)         -> key + value  (removes entry)
+;
+; (walk-search-tree proc tree)
+;   applies PROC in order to all key + value pairs with a non-#f value
+
+(define-record-type tree :tree
+  (make-tree lookup nil root)
+  search-tree?
+  (lookup tree-lookup)
+  (nil    tree-nil)                  ; node marker for missing leaf nodes
+  (root   tree-root set-tree-root!))
+
+(define (make-search-tree = <)
+  (let ((nil (make-node #f #f #f)))
+    (set-node-red?! nil #f)
+    (make-tree (make-lookup = <) nil #f)))
+
+(define-record-type node :node
+  (really-make-node key value parent red? left right)
+  node?
+  (key    node-key    set-node-key!)
+  (value  node-value  set-node-value!)
+  (parent node-parent set-node-parent!)    ; #f in the root node
+  (red?   node-red?   set-node-red?!)      ; for balancing the tree
+  (left   node-left   set-node-left!)      ; left and
+  (right  node-right  set-node-right!))    ;          right subtrees
+
+(define (make-node key value parent)
+  (really-make-node key value parent #t #f #f))
+
+(define-record-discloser :node
+  (lambda (node)
+    (list 'node (node-key node))))
+
+; Lookup up KEY and return its value.
+
+(define (search-tree-ref tree key)
+  (call-with-values
+   (lambda ()
+     ((tree-lookup tree) tree key))
+   (lambda (node parent left?)
+     (if node
+	 (node-value node)
+	 #f))))
+
+; Adding and modifying entries.
+
+(define (search-tree-set! tree key value)
+  (search-tree-modify! tree key (lambda (ignore) value)))
+
+(define (search-tree-modify! tree key proc)
+  (call-with-values
+   (lambda ()
+     ((tree-lookup tree) tree key))
+   (lambda (node parent left?)
+     (let ((new-value (proc (if node (node-value node) #f))))
+       (cond ((and node new-value)
+	      (set-node-value! node new-value))
+	     (new-value
+	      (really-insert! tree parent left? (make-node key new-value parent)))
+	     (node
+	      (really-delete! tree node)))))))
+  
+; Min and max entries.
+
+(define (search-tree-max tree)
+  (real-search-tree-max tree #f))
+
+(define (pop-search-tree-max! tree)
+  (real-search-tree-max tree #t))
+
+(define (real-search-tree-max tree delete?)
+  (let ((node (tree-root tree)))
+    (if node
+	(let loop ((node node))
+	  (cond ((node-right node)
+		 => loop)
+		(else
+		 (if delete?
+		     (really-delete! tree node))
+		 (values (node-key node) (node-value node)))))
+	(values #f #f))))
+
+(define (search-tree-min tree)
+  (real-search-tree-min tree #f))
+
+(define (pop-search-tree-min! tree)
+  (real-search-tree-min tree #t))
+
+(define (real-search-tree-min tree delete?)
+  (let ((node (tree-root tree)))
+    (if node
+	(let loop ((node node))
+	  (cond ((node-left node)
+		 => loop)
+		(else
+		 (if delete?
+		     (really-delete! tree node))
+		 (values (node-key node) (node-value node)))))
+	(values #f #f))))
+
+(define (walk-search-tree proc tree)
+  (let recur ((node (tree-root tree)))
+    (cond (node
+	   (recur (node-left node))
+	   (proc (node-key node) (node-value node))
+	   (recur (node-right node))))))
+
+; Lookup up an entry.  Easy.
+;
+; Hack of checking common case reduced lookup time in a 1000 element search
+; tree by a third.
+
+(define (make-lookup tree-= tree-<)
+  (if (and (eq? tree-= =)
+	   (eq? tree-< <))
+      default-lookup
+      (lambda (tree key)
+	(let loop ((node (tree-root tree))
+		   (parent #f)
+		   (left? #f))
+	  (cond ((not node)
+		 (values #f parent left?))
+		((tree-= (node-key node) key)
+		 (values node #f #f))
+		((tree-< key (node-key node))
+		 (loop (node-left node) node #t))
+		(else
+		 (loop (node-right node) node #f)))))))
+
+(define (default-lookup tree key)
+  (let loop ((node (tree-root tree))
+	     (parent #f)
+	     (left? #f))
+    (cond ((not node)
+	   (values #f parent left?))
+	  ((= (node-key node) key)
+	   (values node #f #f))
+	  ((< key (node-key node))
+	   (loop (node-left node) node #t))
+	  (else
+	   (loop (node-right node) node #f)))))
+
+;----------------------------------------------------------------
+; Little utilities.
+
+; Parameterized node access
+
+(define (node-child node left?)
+  (if left?
+      (node-left node)
+      (node-right node)))
+
+(define (set-node-child! node left? child)
+  (if left?
+      (set-node-left! node child)
+      (set-node-right! node child)))
+
+; Empty leaf slots are considered black.
+
+(define (node-black? node)
+  (not (and node (node-red? node))))
+
+; The next node (used in REALLY-DELETE!)
+
+(define (successor node)
+  (cond ((node-right node)
+	 => (lambda (node)
+	      (let loop ((node node))
+		(cond ((node-left node)
+		       => loop)
+		      (else node)))))
+	(else
+	 (let loop ((node node) (parent (node-parent node)))
+	   (if (and parent
+		    (eq? node (node-right parent)))
+	       (loop parent (node-parent parent))
+	       parent)))))
+
+;----------------------------------------------------------------
+; Add NODE as the LEFT? child of PARENT and balance the tree.
+
+(define (really-insert! tree parent left? node)
+  (if (not parent)
+      (set-tree-root! tree node)
+      (set-node-child! parent left? node))
+  (fixup-insertion! node tree))
+
+; Balance the tree after NODE has been inserted.
+
+(define (fixup-insertion! node tree)
+  (let loop ((node node))
+    (let ((parent (node-parent node)))
+      (if (and parent (node-red? parent))
+	  (let* ((grand (node-parent parent))
+		 (left? (eq? parent (node-left grand)))
+		 (y (node-child grand (not left?))))
+	    (cond ((node-black? y)
+		   (let* ((node (cond ((eq? node (node-child parent (not left?)))
+				       (rotate! parent left? tree)
+				       parent)
+				      (else node)))
+			  (parent (node-parent node))
+			  (grand (node-parent parent)))
+		     (set-node-red?! parent #f)
+		     (set-node-red?! grand  #t)
+		     (rotate! grand (not left?) tree)
+		     (loop node)))
+		  (else
+		   (set-node-red?! parent #f)
+		   (set-node-red?! y      #f)
+		   (set-node-red?! grand  #t)
+		   (loop grand)))))))
+  (set-node-red?! (tree-root tree) #f))
+
+;        A                                 B
+;       / \    =(rotate! A #f tree)=>     / \
+;      B   k                             i   A
+;     / \      <=(rotate! B #t tree)=       / \
+;    i   j                                 j   k
+
+(define (rotate! node left? tree)
+  (let* ((y (node-child node (not left?)))
+	 (y-left (node-child y left?))
+	 (parent (node-parent node)))
+    (set-node-child! node (not left?) y-left)
+    (if y-left
+	(set-node-parent! y-left node))
+    (replace! parent y node tree)
+    (set-node-child! y left? node)
+    (set-node-parent! node y)))
+		
+; Replace CHILD (of PARENT) with NEW-CHILD
+
+(define (replace! parent new-child child tree)
+    (set-node-parent! new-child parent)
+    (cond ((eq? child (tree-root tree))
+	   (set-tree-root! tree new-child))
+	  ((eq? child (node-left parent))
+	   (set-node-left! parent new-child))
+	  (else
+	   (set-node-right! parent new-child))))
+
+; Remove NODE from tree.
+
+(define (really-delete! tree node)
+  (let* ((y (cond ((or (not (node-left node))
+		       (not (node-right node)))
+		   node)
+		  (else
+		   (let ((y (successor node)))
+		     (set-node-key!   node (node-key y))
+		     (set-node-value! node (node-value y))
+		     y))))
+	 (x (or (node-left y)
+		(node-right y)
+		(let ((x (tree-nil tree)))
+		  (set-node-right! y x)
+		  x)))
+	 (parent (node-parent y)))
+    (replace! parent x y tree)
+    (if (not (node-red? y))
+	(fixup-delete! x tree))
+    (let ((nil (tree-nil tree)))
+      (cond ((node-parent nil)
+	     => (lambda (p)
+		  (if (eq? (node-right p) nil)
+		      (set-node-right! p #f)
+		      (set-node-left! p #f))
+		  (set-node-parent! (tree-nil tree) #f)))
+	    ((eq? nil (tree-root tree))
+	     (set-tree-root! tree #f))))))
+
+(define (fixup-delete! x tree)
+  (let loop ((x x))
+    (if (or (eq? x (tree-root tree))
+	    (node-red? x))
+	(set-node-red?! x #f)
+	(let* ((parent (node-parent x))
+	       (left? (eq? x (node-left parent)))
+	       (w (node-child parent (not left?)))
+	       (w (cond ((node-red? w)
+			 (set-node-red?! w #f)
+			 (set-node-red?! parent #t)
+			 (rotate! parent left? tree)
+			 (node-child (node-parent x) (not left?)))
+			(else
+			 w))))
+	  (cond ((and (node-black? (node-left w))
+		      (node-black? (node-right w)))
+		 (set-node-red?! w #t)
+		 (loop (node-parent x)))
+		(else
+		 (let ((w (cond ((node-black? (node-child w (not left?)))
+				 (set-node-red?! (node-child w left?) #f)
+				 (set-node-red?! w #t)
+				 (rotate! w (not left?) tree)
+				 (node-child (node-parent x) (not left?)))
+				(else
+				 w))))
+		   (let ((parent (node-parent x)))
+		     (set-node-red?! w (node-red? parent))
+		     (set-node-red?! parent #f)
+		     (set-node-red?! (node-child w (not left?)) #f)
+		     (rotate! parent left? tree)
+		     (set-node-red?! (tree-root tree) #f)))))))))
+		 
+; Verify that the coloring is correct
+;
+;(define (okay-tree? tree)
+;  (receive (okay? red? count)
+;      (let recur ((node (tree-root tree)))
+;        (if (not node)
+;            (values #t #f 0)
+;            (receive (l-ok? l-r? l-c)
+;                (recur (node-left node))
+;              (receive (r-ok? r-r? r-c)
+;                  (recur (node-right node))
+;                (values (and l-ok?
+;                             r-ok?
+;                             (not (and (node-red? node)
+;                                       (or l-r? r-r?)))
+;                             (= l-c r-c))
+;                        (node-red? node)
+;                        (if (node-red? node)
+;                            l-c
+;                            (+ l-c 1)))))))
+;    okay?))
+;
+;
+;(define (walk-sequences proc list)
+;  (let recur ((list list) (r '()))
+;    (if (null? list)
+;        (proc (reverse r))
+;        (let loop ((list list) (done '()))
+;          (if (not (null? list))
+;              (let ((next (car list)))
+;                (recur (append (reverse done) (cdr list)) (cons next r))
+;                (loop (cdr list) (cons next done))))))))
+;           
+;(define (tree-test n)
+;  (let ((iota (do ((i n (- i 1))
+;                   (l '() (cons i l)))
+;                  ((<= i 0) l))))
+;    (walk-sequences (lambda (in)
+;                      (walk-sequences (lambda (out)
+;                                        (do-tree-test in out))
+;                                      iota))
+;                    iota)
+;    #t))
+;
+;(define (do-tree-test in out)
+;  (let ((tree (make-search-tree = <)))
+;    (for-each (lambda (i)
+;                (search-tree-set! tree i (- 0 i)))
+;              in)
+;    (if (not (okay-tree? tree))
+;        (breakpoint "tree ~S is not okay" in))
+;    (if (not (tree-ordered? tree (length in)))
+;        (breakpoint "tree ~S is not ordered" in))
+;    (for-each (lambda (i)
+;                (if (not (= (search-tree-ref tree i) (- 0 i)))
+;                    (breakpoint "looking up ~S in ~S lost" i in)))
+;              in)
+;    (do ((o out (cdr o)))
+;        ((null? o))
+;      (search-tree-set! tree (car o) #f)
+;      (if (not (okay-tree? tree))
+;          (breakpoint "tree ~S is not okay after deletions ~S" in out)))))
+;
+;(define (tree-ordered? tree count)
+;  (let ((l '()))
+;    (walk-search-tree (lambda (key value)
+;                        (set! l (cons (cons key value) l)))
+;                      tree)
+;    (let loop ((l l) (n count))
+;      (cond ((null? l)
+;             (= n 0))
+;            ((and (= (caar l) n)
+;                  (= (cdar l) (- 0 n)))
+;             (loop (cdr l) (- n 1)))
+;            (else #f)))))
+;
+;(define (do-tests tester)
+;  (do ((i 0 (+ i 1)))
+;      (#f)
+;    (tester i)
+;    (format #t " done with ~D~%" i)))
+;
+;(define (another-test n)
+;  (let ((iota (do ((i n (- i 1))
+;                   (l '() (cons i l)))
+;                  ((<= i 0) l))))
+;    (walk-sequences (lambda (in)
+;                      (do ((i 1 (+ i 1)))
+;                          ((> i n))
+;                        (let ((tree (make-search-tree = <)))
+;                          (for-each (lambda (i)
+;                                      (search-tree-set! tree i (- 0 i)))
+;                                    in)
+;                          (if (not (okay-tree? tree))
+;                              (breakpoint "tree ~S is not okay" in))
+;                          (if (not (tree-ordered? tree (length in)))
+;                              (breakpoint "tree ~S is not ordered" in))
+;                          (for-each (lambda (i)
+;                                      (if (not (= (search-tree-ref tree i) (- 0 i)))
+;                                          (breakpoint "looking up ~S in ~S lost" i in)))
+;                                    in)
+;                          (search-tree-set! tree i #f)
+;                          (if (not (okay-tree? tree))
+;                              (breakpoint "tree ~S is not okay after deletion ~S"
+;                                          in i))
+;                          (for-each (lambda (j)
+;                                      (let ((ref (search-tree-ref tree j)))
+;                                        (if (not (eq? ref (if (= j i) #f (- 0 j))))
+;                                            (breakpoint "looking up ~S in ~S lost" i in))))
+;                                    in))))
+;                    iota)))
diff --git a/scheme/big/socket.scm b/scheme/big/socket.scm
new file mode 100644
index 0000000..1c1abda
--- /dev/null
+++ b/scheme/big/socket.scm
@@ -0,0 +1,117 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Server interface
+;   (open-socket [socket-number]) -> socket
+;   (close-socket socket)
+;   (socket-accept socket) -> [input-port output-port]
+;   (get-host-name) -> string
+;   (socket-port-number socket) -> integer
+
+; Client interface
+;   (socket-client host-name socket-number) -> [input-port output-port]
+
+; Old calls I would like to get rid off.
+;   (socket-listen socket) -> [input-port output-port]
+;   (socket-listen-channels socket) -> [input-channel output-channel]
+;   (socket-client-channels host-name socket-number) -> [input-channels output-channels]
+
+;--------------------
+; Socket type
+;
+; A socket has a channel (for accepting connections) and a port number.
+; These are only used for servers; clients don't need them.
+
+(define-record-type socket :socket
+  (make-socket channel port-number)
+  socket?
+  (channel socket-channel)
+  (port-number socket-port-number))
+
+(define-record-discloser :socket
+  (lambda (s) `(socket ,(socket-port-number s))))
+
+(define (close-socket socket)
+  (close-channel (socket-channel socket)))
+
+; Makes a server socket.
+
+(define (open-socket . maybe-number)
+  (let ((channel (new-socket #t)))
+    (bind-socket channel (if (or (null? maybe-number)
+				 (= (car maybe-number) 0))  ; old, crappy spec
+			     #f
+			     (car maybe-number)))
+    (real-socket-listen channel)
+    (make-socket channel (socket-number channel))))
+
+(define (socket-accept socket)
+  (call-with-values
+   (lambda ()
+     (socket-listen-channels socket))
+   (lambda (in out)
+     (values (input-channel+closer->port in close-socket-input-channel)
+	     (output-channel+closer->port out close-socket-output-channel)))))
+  
+(define socket-listen socket-accept)
+
+(define (socket-listen-channels socket)
+  (let ((channel (socket-channel socket)))
+    (let loop ()
+      (disable-interrupts!)
+      (let ((channels (real-socket-accept channel)))
+	(cond (channels
+	       (enable-interrupts!)
+	       (values (car channels)
+		       (cdr channels)))
+	      (else
+	       (wait-for-channel channel)		; enables interrupts
+	       (loop)))))))
+
+; Connect to the socket and return input and output ports.
+
+(define (socket-client host-name port-number)
+  (call-with-values
+   (lambda ()
+     (socket-client-channels host-name port-number))
+   (lambda (in out)
+     (values (input-channel+closer->port in close-socket-input-channel)
+	     (output-channel+closer->port out close-socket-output-channel)))))
+
+(define (socket-client-channels host-name port-number)
+  (let ((channel (new-socket #f)))
+    (let loop ()
+      (disable-interrupts!)
+      (let ((output-channel (real-socket-connect channel host-name port-number)))
+	(cond ((channel? output-channel)
+	       (enable-interrupts!)
+	       (values channel output-channel))
+	      ; This should never happen.
+	      ((eq? output-channel #t)
+	       (error "client socket already connected" host-name port-number))
+	      (else
+	       (wait-for-channel channel) ; enables interrupts
+	       (loop)))))))
+
+; We need to explicitly close the channel.
+
+(define (close-socket-input-channel channel)
+  (close-socket-half channel #t)
+  (close-channel channel))
+
+(define (close-socket-output-channel channel)
+  (close-socket-half channel #f)
+  (close-channel channel))
+
+; The C calls we use.  These are in c/unix/socket.c.
+
+(import-lambda-definition new-socket (server?) "s48_socket")
+(import-lambda-definition bind-socket (socket number) "s48_bind")
+(import-lambda-definition socket-number (socket) "s48_socket_number")
+(import-lambda-definition real-socket-listen (socket) "s48_listen")
+(import-lambda-definition real-socket-accept (socket) "s48_accept")
+(import-lambda-definition real-socket-connect (socket machine port-number)
+			  "s48_connect")
+(import-lambda-definition close-socket-half (socket input?)
+			  "s48_close_socket_half")
+(import-lambda-definition get-host-name () "s48_get_host_name")
diff --git a/scheme/big/sort.scm b/scheme/big/sort.scm
new file mode 100644
index 0000000..711e9fd
--- /dev/null
+++ b/scheme/big/sort.scm
@@ -0,0 +1,151 @@
+;;; Copyright (c) 1985 Yale University
+;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
+
+;;; This material was developed by the T Project at the Yale
+;;; University Computer Science Department.  Permission to copy this
+;;; software, to redistribute it, and to use it for any purpose is
+;;; granted, subject to the following restric- tions and
+;;; understandings.
+;;; 1. Any copy made of this software must include this copyright
+;;;    notice in full.
+;;; 2. Users of this software agree to make their best efforts (a) to return
+;;;    to the T Project at Yale any improvements or extensions that they make,
+;;;    so that these may be included in future releases; and (b) to inform
+;;;    the T Project of noteworthy uses of this software.
+;;; 3. All materials developed as a consequence of the use of this software
+;;;    shall duly acknowledge such use, in accordance with the usual standards
+;;;    of acknowledging credit in academic research.
+;;; 4. Yale has made no warrantee or representation that the operation of
+;;;    this software will be error-free, and Yale is under no obligation to
+;;;    provide any services, by way of maintenance, update, or otherwise.
+;;; 5. In conjunction with products arising from the use of this material,
+;;;    there shall be no use of the name of the Yale University nor of any
+;;;    adaptation thereof in any advertising, promotional, or sales literature
+;;;    without prior written consent from Yale in each case.
+;;;
+
+;;; We gratefully acknowledge Bob Nix
+
+;;;  SORT:ONLINE-MERGE-SORT!
+;;;  =======================
+;;;  On-Line Merge sort, a fast and stable algorithm for sorting a list.
+;;;  This is a very neat algorithm!  Consider the following code:
+;;;
+;;;    (DEFINE (MERGE-SORT L)
+;;;        (IF (NULL? (CDR L))
+;;;            L
+;;;            (MERGE (MERGE-SORT (FIRST-HALF-OF L))
+;;;                   (MERGE-SORT (SECOND-HALF-OF L)))))
+;;;
+;;;  The nested calls to MERGE above form a binary tree, with MERGE's of
+;;;  singleton lists at the leaves, and a MERGE of two lists of size N/2 at
+;;;  the top.  The algorithm below traverses this MERGE-tree in post-order,
+;;;  moving from the lower left hand corner to the right.
+;;;
+;;;  This algorithm sorts N objects with about NlgN+2N comparisons and exactly
+;;;  lgN conses.  The algorithm used is a version of mergesort that is
+;;;  amenable to Lisp's data accessing primitives.  The first phase of the
+;;;  algorithm is an "addition" phase in which each element X is added to
+;;;  a list of lists of sorted runs B in much the same manner as a one is
+;;;  added to a binary number.  If the first "digit" of B is 0, i.e. the first
+;;;  list in B is NIL, then the element to be added becomes the first digit
+;;;  of B.  If that digit is non empty then you merge the digit with X and
+;;;  recurse on the rest of B -- setting the first digit of B to be zero.
+;;;  For example:
+;;;
+;;;   Reversed      LIST B
+;;;   Binary #     Each sublist is sorted.
+;;;
+;;;    0000        ()
+;;;    1000        ((x))
+;;;    0100        (()  (x x))
+;;;    1100        ((x) (x x))
+;;;    0010        (()  ()    (x x x x))
+;;;    1010        ((x) ()    (x x x x))
+;;;    0110        (()  (x x) (x x x x))
+;;;    1110        ((x) (x x) (x x x x))
+;;;    0001        (()  ()    ()        (x x x x x x x x))
+;;;    1001        ((x) ()    ()        (x x x x x x x x))
+;;;
+;;;  The algorithm then merges the sublists of these lists into
+;;;  one list, and returns that list.
+;;;
+;;;  To see the algorithm in action, trace LIST-MERGE!.
+;;;
+
+;;; Returns list L sorted using OBJ-< for comparisons.
+
+(define (sort-list l obj-<)
+  (cond ((or (null? l)
+             (null? (cdr l)))
+         l)
+        (else
+         (online-merge-sort! (append l '())    ; copy-list
+			     obj-<))))
+
+;;; Returns list L sorted using OBJ-< for comparisons.
+;;; L is destructively altered.
+
+(define (sort-list! l obj-<)
+  (cond ((or (null? l)
+             (null? (cdr l)))
+         l)
+        (else
+         (online-merge-sort! l obj-<))))
+
+;;; The real sort procedure.  Elements of L are added to B, a list of sorted
+;;; lists as defined above.  When all elements of L have been added to B
+;;; the sublists of B are merged together to get the desired sorted list.
+
+(define (online-merge-sort! l obj-<)
+  (let ((b (cons '() '())))
+    (let loop ((l l))
+      (cond ((null? l)
+             (do ((c (cddr b) (cdr c))
+                  (r (cadr b) (list-merge! (car c) r obj-<)))
+                 ((null? c)
+                  r)))
+            (else
+             (let ((new-l (cdr l)))
+               (set-cdr! l '())
+               (add-to-sorted-lists l b obj-<)
+               (loop new-l)))))))
+
+;;; X is a list that is merged into B, the list of sorted lists.
+
+(define (add-to-sorted-lists x b obj-<)
+  (let loop ((x x) (b b))
+    (let ((l (cdr b)))
+      (cond ((null? l)
+             (set-cdr! b (cons x '())))
+            ((null? (car l))
+             (set-car! l x))
+            (else
+             (let ((y (list-merge! x (car l) obj-<)))
+                (set-car! l '())
+                (loop y l)))))))
+
+;;; Does a stable side-effecting merge of L1 and L2.
+
+(define (list-merge! l1 l2 obj-<)
+  (cond ((null? l1) l2)
+        ((null? l2) l1)
+        ((obj-< (car l1) (car l2))
+         (real-list-merge! l2 (cdr l1) obj-< l1)
+         l1)
+        (else
+         (real-list-merge! l1 (cdr l2) obj-< l2)
+         l2)))
+
+;;; Does the real work of LIST-MERGE!.  L1 is assumed to be non-empty.
+
+(define (real-list-merge! l1 l2 obj-< prev)
+  (let loop ((a l1) (b l2) (prev prev))
+    (cond ((null? b)
+           (set-cdr! prev a))
+          ((obj-< (car a) (car b))
+           (set-cdr! prev a)
+           (loop b (cdr a) a))
+          (else
+           (set-cdr! prev b)
+           (loop a (cdr b) b)))))
diff --git a/scheme/big/strong.scm b/scheme/big/strong.scm
new file mode 100644
index 0000000..838ccf6
--- /dev/null
+++ b/scheme/big/strong.scm
@@ -0,0 +1,152 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Code to find the strongly connected components of a graph.
+; (TO <vertex>) are the vertices that have an edge to <vertex>.
+; (SLOT <vertex>) and (SET-SLOT! <vertex> <value>) is a settable slot
+; used by the algorithm.
+;
+; The components are returned in a backwards topologically sorted list.
+
+(define (strongly-connected-components vertices to slot set-slot!)
+  (make-vertices vertices to slot set-slot!)
+  (let loop ((to-do vertices) (index 0) (stack #t) (comps '()))
+    (let ((to-do (find-next-vertex to-do slot)))
+      (cond ((null? to-do)
+	     (for-each (lambda (n) (set-slot! n #f)) vertices)
+	     comps)
+	    (else
+	     (call-with-values
+	      (lambda () 
+		(do-vertex (slot (car to-do)) index stack comps))
+	      (lambda (index stack comps)
+		(loop to-do index stack comps))))))))
+
+(define (find-next-vertex vertices slot)
+  (do ((vertices vertices (cdr vertices)))
+      ((or (null? vertices)
+           (= 0 (vertex-index (slot (car vertices)))))
+       vertices)))
+  
+(define-record-type vertex :vertex
+  (really-make-vertex data edges stack index parent lowpoint)
+  vertex?
+  (data vertex-data)    ; user's data
+  (edges vertex-edges set-vertex-edges!)    ; list of vertices
+  (stack vertex-stack set-vertex-stack!)    ; next vertex on the stack
+  (index vertex-index set-vertex-index!)    ; time at which this vertex was
+                                            ; reached in the traversal
+  (parent vertex-parent set-vertex-parent!) ; a vertex pointing to this one
+  (lowpoint vertex-lowpoint set-vertex-lowpoint!)) ; lowest index in this
+                                     ; vertices strongly connected component
+
+(define (make-vertex data)
+  (really-make-vertex data '() #f 0 #f #f))
+
+(define (make-vertices vertices to slot set-slot!)
+  (let ((maybe-slot (lambda (n)
+		      (let ((s (slot n)))
+			(if (vertex? s)
+			    s
+			    (error "graph edge points to non-vertex" n))))))
+    (for-each (lambda (n)
+		(set-slot! n (make-vertex n)))
+	      vertices)
+    (for-each (lambda (n)
+		(set-vertex-edges! (slot n) (map maybe-slot (to n))))
+	      vertices)
+    (values)))
+
+; The numbers are the algorithm step numbers from page 65 of Graph Algorithms,
+; Shimon Even, Computer Science Press, 1979.
+
+; 2
+
+(define (do-vertex vertex index stack comps)
+  (let ((index (+ index '1)))
+    (set-vertex-index!    vertex index)
+    (set-vertex-lowpoint! vertex index)
+    (set-vertex-stack!    vertex stack)
+    (get-strong vertex index vertex comps)))
+
+; 3
+
+(define (get-strong vertex index stack comps)
+  (if (null? (vertex-edges vertex))
+      (end-vertex    vertex index stack comps)
+      (follow-edge vertex index stack comps)))
+
+; 7
+
+(define (end-vertex vertex index stack comps)
+  (call-with-values
+   (lambda ()
+     (if (= (vertex-index vertex) (vertex-lowpoint vertex))
+	 (unwind-stack vertex stack comps)
+	 (values stack comps)))
+   (lambda (stack comps)
+     (cond ((vertex-parent vertex)
+	    => (lambda (parent)
+		 (if (> (vertex-lowpoint parent) (vertex-lowpoint vertex))
+		     (set-vertex-lowpoint! parent (vertex-lowpoint vertex)))
+		 (get-strong parent index stack comps)))
+	   (else
+	    (values index stack comps))))))
+
+(define (unwind-stack vertex stack comps)
+  (let loop ((n stack) (c '()))
+    (let ((next (vertex-stack n))
+          (c (cons (vertex-data n) c)))
+      (set-vertex-stack! n #f)
+      (if (eq? n vertex)
+          (values next (cons c comps))
+          (loop next c)))))
+
+; 4
+
+(define (follow-edge vertex index stack comps)
+  (let* ((next (pop-vertex-edge! vertex))
+         (next-index (vertex-index next)))
+    (cond ((= next-index 0)
+           (set-vertex-parent! next vertex)
+           (do-vertex next index stack comps))
+          (else
+           (if (and (< next-index (vertex-index vertex))
+                    (vertex-stack next)
+                    (< next-index (vertex-lowpoint vertex)))
+               (set-vertex-lowpoint! vertex next-index))
+           (get-strong vertex index stack comps)))))
+
+(define (pop-vertex-edge! vertex)
+  (let ((edges (vertex-edges vertex)))
+    (set-vertex-edges! vertex (cdr edges))
+    (car edges)))
+
+; GRAPH is ((<symbol> . <symbol>*)*)
+             
+;(define (test-strong graph)
+;  (let ((vertices (map (lambda (n)
+;                         (vector (car n) #f #f))
+;                       graph)))
+;    (for-each (lambda (data vertex)
+;                (vector-set! vertex 1 (map (lambda (s)
+;                                             (first (lambda (v)
+;                                                      (eq? s (vector-ref v 0)))
+;                                                    vertices))
+;                                           (cdr data))))
+;              graph
+;              vertices)
+;    (map (lambda (l)
+;           (map (lambda (n) (vector-ref n 0)) l))
+;         (strongly-connected-components vertices
+;                                        (lambda (v) (vector-ref v 1))
+;                                        (lambda (v) (vector-ref v 2))
+;                                        (lambda (v val)
+;                                          (vector-set! v 2 val))))))
+
+
+
+
+
+
+
diff --git a/scheme/comp-packages.scm b/scheme/comp-packages.scm
new file mode 100644
index 0000000..f32f0b5
--- /dev/null
+++ b/scheme/comp-packages.scm
@@ -0,0 +1,338 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Various data structures used by the compiler, module system, etc.
+
+; Type system
+
+(define-structure meta-types meta-types-interface
+  (open scheme-level-2
+	define-record-types tables bitwise
+	features ;make-immutable!
+	util signals)
+  (files (bcomp mtype))
+  (optimize auto-integrate))
+
+; Bindings
+
+(define-structure bindings bindings-interface
+  (open scheme-level-2
+	meta-types
+	locations)
+  (files (bcomp binding))
+  (optimize auto-integrate))
+
+; Names & Transforms
+
+(define-structures ((names names-interface)
+		    (transforms transforms-interface))
+  (open scheme-level-2
+	define-record-types tables
+	signals
+	meta-types	;sexp->type
+	bindings	;same-denotation?
+	features)	;make-immutable! string-hash
+  (files (bcomp name)
+	 (bcomp transform))
+  (optimize auto-integrate))
+
+; A thingie (placecard?) is used to hold a spot for a location that is to be
+; found later.  The compiler sticks them in templates and the module system
+; later replaces them with locations.
+;
+; We can't use (BEGIN ...) for this trivial package because it is loaded
+; by flatload, which can't handle them.
+
+(define-structure thingies (export make-thingie
+				   thingie?
+				   thingie-binding
+				   thingie-name
+				   thingie-want-type)
+  (open scheme-level-2 define-record-types)
+  (optimize auto-integrate)
+  (files (bcomp thingie)))
+
+; Nodes
+
+(define-structure nodes nodes-interface
+  (open scheme-level-2
+	meta-types names
+	signals define-record-types tables
+	util)
+  (files (bcomp node)
+	 (bcomp schemify))
+  (optimize auto-integrate))
+
+(define-structure compiler-envs compiler-envs-interface
+  (open scheme-level-2
+	meta-types names bindings)
+  (files (bcomp cenv))
+  (optimize auto-integrate))
+
+;--------------------------------
+; Macros
+
+(define-structure syntactic syntactic-interface
+  (open scheme-level-2 util
+	meta-types names bindings
+	nodes compiler-envs
+	signals tables fluids
+	var-utilities
+	transforms
+	features)		;make-immutable!
+  (files (bcomp syntax))
+  (optimize auto-integrate))
+
+(define-structure usual-macros usual-macros-interface
+  (open scheme-level-2
+	names		;name?
+	fluids		;used in definition of %file-name%
+	util
+	tables signals)
+  (files (bcomp usual)
+	 (bcomp rules)))
+
+; Little utilities to be phased out by changing the format of lambda var lists
+; in nodes.
+
+(define-structure var-utilities (export n-ary?
+					normalize-formals
+					number-of-required-args)
+  (open scheme-level-2)
+  (files (bcomp var-util))) ; can't use (BEGIN ...) because this is flatloaded
+
+;--------------------------------
+; Byte-code compiler
+
+; Lexical environment layout info for debugging
+
+(define-structure debug-data debug-data-interface
+  (open scheme-level-2 
+	define-record-types)
+  (files (bcomp ddata))
+  (optimize auto-integrate))
+
+; Determining stack usage.
+
+(define-structure stack-check (export maximum-stack-use)
+  (open scheme-level-2 architecture code-vectors signals)
+  (files (bcomp stack-check))
+  (optimize auto-integrate))
+
+; Compiler back end
+
+(define-structure segments segments-interface
+  (open scheme-level-2 util tables fluids signals
+	define-record-types
+	features		;make-immutable!
+	records			;for debug-flags randomness
+	code-vectors
+	templates
+	architecture
+	debug-data
+	thingies
+	stack-check)
+  (files (bcomp state)
+	 (bcomp segment))
+  (optimize auto-integrate))
+
+; Primops
+
+(define-structure primops primops-interface
+  (open scheme-level-2 tables define-record-types
+	meta-types
+	signals)
+  (files (bcomp primop))
+  (optimize auto-integrate))
+
+; Type reconstruction.
+
+(define-structure reconstruction (export node-type reconstruct-type)
+  (open scheme-level-2 tables
+	meta-types nodes names bindings
+	primops
+	var-utilities		;n-ary?
+	util			;last
+	signals)
+  (files (bcomp recon)))
+
+; The compiler itself.
+
+(define-structure compiler compiler-interface
+  (open scheme-level-2 util fluids signals
+	features		;force-output
+	enumerated		;enumerand->name
+	architecture
+	meta-types names bindings
+	transforms
+	nodes var-utilities
+	primops
+	segments
+	reconstruction)
+  (files (bcomp comp-exp)
+	 (bcomp comp-prim)
+	 (bcomp comp))
+  (optimize auto-integrate))
+
+;----------------
+; Reading the forms in a file.
+; This is used by scan-package and rts/eval.scm.
+
+(define-structure reading-forms (export read-forms $note-file-package)
+  (open scheme-level-2
+	fluids filenames
+	features		;current-noise-port force-output
+	)
+  (files (bcomp read-form)))
+
+;----------------
+; Optional compiler pass.
+
+(define-structure flat-environments (export flatten-form)
+  (open scheme-level-2 nodes signals
+	optimizer primops
+	var-utilities)
+  (files (opt flatten)))
+
+;----------------
+; Module system
+
+(define-structure interfaces interfaces-interface
+  (open scheme-level-2
+	define-record-types tables
+	weak	; populations
+	meta-types)
+  (files (bcomp interface))
+  (optimize auto-integrate))
+
+(define-structures ((packages packages-interface)
+		    (packages-internal packages-internal-interface)
+		    (undefined undefined-interface))
+  (open scheme-level-2
+	define-record-types tables fluids signals
+	util features locations weak
+        meta-types interfaces
+	names bindings
+	compiler-envs
+	templates
+	thingies)
+  (files (bcomp package)
+	 (bcomp package-undef))
+  (optimize auto-integrate))
+
+(define-structure scan-package scan-package-interface
+  (open scheme-level-2 util
+	packages packages-internal
+	meta-types bindings
+	reading-forms
+	filenames
+	signals
+	features		;current-noise-port force-output
+	)
+  (files (bcomp scan-package)))
+
+(define-structure optimizer optimizer-interface
+  (open scheme-level-2
+	signals tables
+	util)
+  (files (bcomp optimize)))
+
+(define-structure compile-packages (export compile-package)
+  (open scheme-level-2 util tables
+	syntactic
+	packages
+	packages-internal	;package-name
+	optimizer
+	compiler
+	primops			;walk-primops
+	compiler-envs
+	nodes
+	scan-package
+	usual-macros		;for usual-transforms
+	transforms		;for usual-transforms
+	meta-types)		;for usual-transforms and define-all-operators
+  (files (bcomp comp-package)))
+
+;----------------
+; DEFINE-STRUCTURE and friends
+
+(define-structure defpackage defpackage-interface
+  (open scheme-level-2
+	packages syntactic usual-macros types
+	interfaces
+	source-file-names	;%file-name%
+	signals			;error
+	tables)
+  (for-syntax (open scheme-level-2 signals))     ;syntax-error
+  (files (bcomp module-language)
+	 (bcomp config)))
+
+(define-structure types types-interface  ;Typing language
+  (open scheme-level-2 meta-types syntactic loopholes)
+  (files (bcomp type))
+  ;; (optimize auto-integrate)  - doesn't work
+  )
+
+(define-structure module-system (compound-interface defpackage-interface
+						    types-interface)
+  (open defpackage types))
+
+;----------------
+; Code analysis and inlining
+
+(define-structure usages usages-interface
+  (open scheme-level-2
+	meta-types names nodes
+	packages
+	packages-internal	;package-refine-type!
+	reconstruction
+	var-utilities
+	define-record-types
+	util signals tables strong)
+  (files (opt usage)
+         (opt sort)))
+
+(define-structure analysis (export analyze-forms)
+  (open scheme-level-2
+	meta-types bindings nodes
+	packages-internal	;package-add-static!
+	inline
+	usages
+	reconstruction
+	var-utilities
+	transforms
+	packages
+	signals
+	features		;force-output
+	optimizer		;set-optimizer!
+	util)
+  (files (opt analyze)))
+
+(define-structure inline inline-interface
+  (open scheme-level-2 util var-utilities
+	meta-types names bindings nodes
+	compiler-envs
+	transforms
+	packages
+	usages
+	signals)
+  (files (opt inline)))
+
+(define-structure strong (export strongly-connected-components)
+  (open scheme-level-2 define-record-types signals)
+  (files (big strong))) ;!
+
+;----------------
+; Two basic structures needed to support the compiler.
+
+(define-structure tables general-tables-interface
+  (open scheme-level-1
+	define-record-types
+	signals
+	features)    ; string-hash, make-immutable!
+  (files (big general-table))
+  (optimize auto-integrate))
+
+(define-structure filenames filenames-interface
+  (open scheme-level-1 signals)
+  (files (big filename)))
+
diff --git a/scheme/debug-packages.scm b/scheme/debug-packages.scm
new file mode 100644
index 0000000..de88de2
--- /dev/null
+++ b/scheme/debug-packages.scm
@@ -0,0 +1,133 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Handy things for debugging the run-time system, byte code compiler,
+; and linker.
+
+
+; Alternative command processor.  Handy for debugging the bigger one.
+
+(define (make-mini-command scheme)
+  (define-structure mini-command (export command-processor)
+    (open scheme
+	  signals conditions handle
+	  display-conditions
+	  i/o)   ; current-error-port
+    (files (debug mini-command)))
+  mini-command)
+
+; Miniature EVAL, for debugging runtime system sans package system.
+
+(define-structures ((mini-eval evaluation-interface)
+		    (mini-environments
+		     (export interaction-environment
+			     scheme-report-environment
+			     set-interaction-environment!
+			     set-scheme-report-environment!)))
+  (open scheme-level-2
+	signals)		;error
+  (files (debug mini-eval)))
+
+(define (make-scheme environments evaluation) ;cf. initial-packages.scm
+  (define-structure scheme scheme-interface
+    (open scheme-level-2
+	  environments
+	  evaluation))
+  scheme)
+
+; Stand-alone system that doesn't contain a byte-code compiler.
+; This is useful for various testing purposes.
+
+(define mini-scheme (make-scheme mini-environments mini-eval))
+
+(define mini-command (make-mini-command mini-scheme))
+
+(define-structure little-system (export start)
+  (open scheme-level-1
+	mini-command
+	usual-resumer)
+  (begin (define start
+	   (usual-resumer
+	    (lambda (args) (command-processor #f args))))))
+
+(define (link-little-system)
+  (link-simple-system '(scheme/debug little)
+		      'start
+		      little-system))
+
+
+
+; --------------------
+; Hack: smallest possible reified system.
+
+(define-structures ((mini-for-reification for-reification-interface)
+		    (mini-packages (export make-simple-package)))
+  (open scheme-level-2
+	features		;contents
+	locations
+	signals)		;error
+  (files (debug mini-package)))
+
+(define-structure mini-system (export start)
+  (open mini-scheme
+	mini-command
+	mini-for-reification
+	mini-packages
+	mini-environments		;set-interaction-environment!
+        usual-resumer
+	conditions handle		;error? with-handler
+	signals)			;error
+  (files (debug mini-start)))
+
+(define (link-mini-system)
+  (link-reified-system (list (cons 'scheme mini-scheme)
+			     (cons 'write-images write-images)
+			     (cons 'primitives primitives) ;just for fun
+			     (cons 'usual-resumer usual-resumer)
+			     (cons 'command mini-command))
+		       '(scheme/debug mini)
+		       'start
+		       mini-system mini-for-reification))
+
+
+
+; --------------------
+; S-expression (nodes, really) interpreter
+
+(define-structure run evaluation-interface
+  (open scheme-level-2
+	packages        	;package-uid package->environment link!
+	compiler-envs		;bind-source-filename
+	reading-forms		;read-forms $note-file-package
+	syntactic		;scan-forms expand-forms
+	signals
+	fluids)
+  (files (debug run)))
+
+
+; Hack: an interpreter-based system.
+
+(define (link-medium-system)		;cf. initial.scm
+
+  (def medium-scheme (make-scheme environments run))
+
+  (let ()
+
+    (def command (make-mini-command medium-scheme))
+
+    (let ()
+
+      (def medium-system
+	;; Cf. initial-packages.scm
+	(make-initial-system medium-scheme command))
+
+      (let ((structs (list (cons 'scheme medium-scheme)
+			   (cons 'primitives primitives) ;just for fun
+			   (cons 'usual-resumer usual-resumer)
+			   (cons 'command command))))
+
+	(link-reified-system structs
+			     '(scheme/debug medium)
+			     `(start ',(map car structs))
+			     medium-system for-reification)))))
+
diff --git a/scheme/debug/bench.scm b/scheme/debug/bench.scm
new file mode 100644
index 0000000..d671780
--- /dev/null
+++ b/scheme/debug/bench.scm
@@ -0,0 +1,23 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Tiny benchmarking image.
+
+; This returns the result of calling recursive FIB on its first argument.
+
+(define (start arg in out error)
+  (fib (string->integer (vector-ref arg 0))))
+
+(define (string->integer s)
+  (letrec ((loop (lambda (i r)
+		   (if (= i (string-length s))
+		       r
+		       (loop (+ i 1)
+			     (+ (- (char->ascii (string-ref s i))
+				   (char->ascii #\0))
+				(* 10 r)))))))
+    (loop 0 0)))
+
+(define (fib n)
+  (if (< n 2)
+      1
+      (+ (fib (- n 1)) (fib (- n 2)))))
diff --git a/scheme/debug/byte-code-test.scm b/scheme/debug/byte-code-test.scm
new file mode 100644
index 0000000..c031843
--- /dev/null
+++ b/scheme/debug/byte-code-test.scm
@@ -0,0 +1,85 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Test various of the byte-codes
+
+;(let ((system (make-system '("~/s48/x48/boot/byte-code-test.scm") 'resume #f)))
+;  (write-system system "~/s48/x48/boot/byte-code-test.image"))
+
+(define *tests* '())
+(define *output-channel* #f)
+
+(define (make-test . args)
+  (set! *tests* (cons args *tests*)))
+
+(define (run-test string compare result proc)
+  (write-string string *output-channel*)
+  (write-string "..." *output-channel*)
+  (write-string (if (compare (proc) result) "OK" "failed") *output-channel*)
+  (newline *output-channel*))
+
+(make-test "testing test mechanism" (lambda (x y) (eq? x y)) 0 (lambda () 0))
+(make-test "primitive catch and throw" (lambda (x y) (eq? x y)) 10
+	   (lambda ()
+	     (* 10 (primitive-catch (lambda (k)
+				      (my-primitive-throw k 1)
+				      (message "after throw???")
+				      2)))))
+
+
+(define (my-primitive-throw cont value)
+  (with-continuation cont (lambda () value)))
+
+(define (message string)
+  (write-string string *output-channel*)
+  (newline channel))
+
+(define (write-string string channel)
+  (channel-write string
+		 0
+		 (string-length string)
+		 channel))
+
+(define (newline channel)
+  (write-string "
+" channel))
+
+(define (resume arg in out error)
+  (set! *output-channel* out)
+  (do ((tests (do ((tests *tests* (cdr tests))
+		   (r '() (cons (car tests) r)))
+		  ((eq? '() tests) r))
+	      (cdr tests)))
+      ((eq? '() tests))
+    (apply run-test (car tests)))
+  (write-string "done" *output-channel*)
+  (newline *output-channel*)
+  (halt 0))
+
+(define *initial-bindings* '())
+
+(define (initial-env name)
+  (let ((probe (assq name *initial-bindings*)))
+    (if probe (cdr probe) (error "unbound" name))))
+
+(define (define-initial name val)
+  (let* ((probe (assq name *initial-bindings*))
+	 (loc (if probe
+		  (cdr probe)
+		  (let ((loc (make-undefined-location name)))
+		    (set! *initial-bindings*
+			  (cons (cons name loc) *initial-bindings*))
+		    loc))))
+    ;; (set-location-defined?! loc #t)  - obsolescent?
+    (set-contents! loc val)))
+
+(for-each (lambda (name val)
+	    (define-initial name val))
+          '(    cons car cdr + - * < = > list map append reverse)
+	  (list cons car cdr + - * < = > list map append reverse))
+
+(make-test "little env-lookup test" eq? car
+	   (lambda ()
+	     (contents (initial-env 'car))))
+
+(define (error string . stuff) (message string))
diff --git a/scheme/debug/check.scm b/scheme/debug/check.scm
new file mode 100644
index 0000000..12278e1
--- /dev/null
+++ b/scheme/debug/check.scm
@@ -0,0 +1,315 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; The barest skeleton of a test suite.
+; Mostly it makes sure that many of the external packages load without
+; error.
+
+; ,exec ,load debug/check.scm
+; (done)
+
+(load-package 'testing)
+
+(config '(run 
+	  (define-structure bar (export)
+	    (open scheme testing))))
+
+(in 'bar '(bench off))
+(in 'bar '(run (define (foo) (cadr '(a b)))))
+(in 'bar '(run (define cadr list)))
+(in 'bar '(run (test "non-bench" equal? '((a b)) (foo))))
+
+(in 'bar '(bench on))
+(in 'bar '(run (define (foo) (car '(a b)))))
+(in 'bar '(run (define car list)))
+(in 'bar '(run (test "bench" equal? 'a (foo))))
+
+(config '(run
+	  (define-structure test1 (export x)
+	    (open scheme testing)
+	    (begin (define x 10)
+		   (define (z) x)))))
+(config '(run 
+	  (define-structure test2 (export)
+	    (open scheme test1 testing)
+	    (begin (define (z) x)))))
+(config '(run
+	  (define-structure test3 (export)
+	    (open scheme test1 testing)
+	    (begin (define (z) x)))))
+(load-package 'test2)
+(load-package 'test3)
+(in 'test3 '(run (define x 20)))
+(in 'test3 '(open test2))
+(in 'test2 '(run (test "shadowing" = 10 (z))))
+(in 'test3 '(run (test "shadowing" = 20 (z))))
+(in 'test1 '(run (test "shadowing" = 10 (z))))
+
+(config '(run 
+(define-structure foo (export)
+  (open scheme testing
+	assembler
+	code-vectors
+	ports
+	queues
+	random
+	sort
+	big-scheme
+	arrays
+	dump/restore
+	search-trees
+	threads
+	placeholders
+	locks
+	interrupts
+	sockets
+	sicp)
+  (begin
+
+(test "1000 args"
+      equal?
+      '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 
+	100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 
+	200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 
+	300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 
+	400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 
+	500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 
+	600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 
+	700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 
+	800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 
+	900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 
+	)
+      (let ((f (lambda (x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40 x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60 x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 x71 x72 x73 x74 x75 x76 x77 x78 x79 x80 x81 x82 x83 x84 x85 x86 x87 x88 x89 x90 x91 x92 x93 x94 x95 x96 x97 x98 x99 
+			x100 x101 x102 x103 x104 x105 x106 x107 x108 x109 x110 x111 x112 x113 x114 x115 x116 x117 x118 x119 x120 x121 x122 x123 x124 x125 x126 x127 x128 x129 x130 x131 x132 x133 x134 x135 x136 x137 x138 x139 x140 x141 x142 x143 x144 x145 x146 x147 x148 x149 x150 x151 x152 x153 x154 x155 x156 x157 x158 x159 x160 x161 x162 x163 x164 x165 x166 x167 x168 x169 x170 x171 x172 x173 x174 x175 x176 x177 x178 x179 x180 x181 x182 x183 x184 x185 x186 x187 x188 x189 x190 x191 x192 x193 x194 x195 x196 x197 x198 x199 
+			x200 x201 x202 x203 x204 x205 x206 x207 x208 x209 x210 x211 x212 x213 x214 x215 x216 x217 x218 x219 x220 x221 x222 x223 x224 x225 x226 x227 x228 x229 x230 x231 x232 x233 x234 x235 x236 x237 x238 x239 x240 x241 x242 x243 x244 x245 x246 x247 x248 x249 x250 x251 x252 x253 x254 x255 x256 x257 x258 x259 x260 x261 x262 x263 x264 x265 x266 x267 x268 x269 x270 x271 x272 x273 x274 x275 x276 x277 x278 x279 x280 x281 x282 x283 x284 x285 x286 x287 x288 x289 x290 x291 x292 x293 x294 x295 x296 x297 x298 x299 
+			x300 x301 x302 x303 x304 x305 x306 x307 x308 x309 x310 x311 x312 x313 x314 x315 x316 x317 x318 x319 x320 x321 x322 x323 x324 x325 x326 x327 x328 x329 x330 x331 x332 x333 x334 x335 x336 x337 x338 x339 x340 x341 x342 x343 x344 x345 x346 x347 x348 x349 x350 x351 x352 x353 x354 x355 x356 x357 x358 x359 x360 x361 x362 x363 x364 x365 x366 x367 x368 x369 x370 x371 x372 x373 x374 x375 x376 x377 x378 x379 x380 x381 x382 x383 x384 x385 x386 x387 x388 x389 x390 x391 x392 x393 x394 x395 x396 x397 x398 x399 
+			x400 x401 x402 x403 x404 x405 x406 x407 x408 x409 x410 x411 x412 x413 x414 x415 x416 x417 x418 x419 x420 x421 x422 x423 x424 x425 x426 x427 x428 x429 x430 x431 x432 x433 x434 x435 x436 x437 x438 x439 x440 x441 x442 x443 x444 x445 x446 x447 x448 x449 x450 x451 x452 x453 x454 x455 x456 x457 x458 x459 x460 x461 x462 x463 x464 x465 x466 x467 x468 x469 x470 x471 x472 x473 x474 x475 x476 x477 x478 x479 x480 x481 x482 x483 x484 x485 x486 x487 x488 x489 x490 x491 x492 x493 x494 x495 x496 x497 x498 x499 
+			x500 x501 x502 x503 x504 x505 x506 x507 x508 x509 x510 x511 x512 x513 x514 x515 x516 x517 x518 x519 x520 x521 x522 x523 x524 x525 x526 x527 x528 x529 x530 x531 x532 x533 x534 x535 x536 x537 x538 x539 x540 x541 x542 x543 x544 x545 x546 x547 x548 x549 x550 x551 x552 x553 x554 x555 x556 x557 x558 x559 x560 x561 x562 x563 x564 x565 x566 x567 x568 x569 x570 x571 x572 x573 x574 x575 x576 x577 x578 x579 x580 x581 x582 x583 x584 x585 x586 x587 x588 x589 x590 x591 x592 x593 x594 x595 x596 x597 x598 x599 
+			x600 x601 x602 x603 x604 x605 x606 x607 x608 x609 x610 x611 x612 x613 x614 x615 x616 x617 x618 x619 x620 x621 x622 x623 x624 x625 x626 x627 x628 x629 x630 x631 x632 x633 x634 x635 x636 x637 x638 x639 x640 x641 x642 x643 x644 x645 x646 x647 x648 x649 x650 x651 x652 x653 x654 x655 x656 x657 x658 x659 x660 x661 x662 x663 x664 x665 x666 x667 x668 x669 x670 x671 x672 x673 x674 x675 x676 x677 x678 x679 x680 x681 x682 x683 x684 x685 x686 x687 x688 x689 x690 x691 x692 x693 x694 x695 x696 x697 x698 x699 
+			x700 x701 x702 x703 x704 x705 x706 x707 x708 x709 x710 x711 x712 x713 x714 x715 x716 x717 x718 x719 x720 x721 x722 x723 x724 x725 x726 x727 x728 x729 x730 x731 x732 x733 x734 x735 x736 x737 x738 x739 x740 x741 x742 x743 x744 x745 x746 x747 x748 x749 x750 x751 x752 x753 x754 x755 x756 x757 x758 x759 x760 x761 x762 x763 x764 x765 x766 x767 x768 x769 x770 x771 x772 x773 x774 x775 x776 x777 x778 x779 x780 x781 x782 x783 x784 x785 x786 x787 x788 x789 x790 x791 x792 x793 x794 x795 x796 x797 x798 x799 
+			x800 x801 x802 x803 x804 x805 x806 x807 x808 x809 x810 x811 x812 x813 x814 x815 x816 x817 x818 x819 x820 x821 x822 x823 x824 x825 x826 x827 x828 x829 x830 x831 x832 x833 x834 x835 x836 x837 x838 x839 x840 x841 x842 x843 x844 x845 x846 x847 x848 x849 x850 x851 x852 x853 x854 x855 x856 x857 x858 x859 x860 x861 x862 x863 x864 x865 x866 x867 x868 x869 x870 x871 x872 x873 x874 x875 x876 x877 x878 x879 x880 x881 x882 x883 x884 x885 x886 x887 x888 x889 x890 x891 x892 x893 x894 x895 x896 x897 x898 x899 
+			x900 x901 x902 x903 x904 x905 x906 x907 x908 x909 x910 x911 x912 x913 x914 x915 x916 x917 x918 x919 x920 x921 x922 x923 x924 x925 x926 x927 x928 x929 x930 x931 x932 x933 x934 x935 x936 x937 x938 x939 x940 x941 x942 x943 x944 x945 x946 x947 x948 x949 x950 x951 x952 x953 x954 x955 x956 x957 x958 x959 x960 x961 x962 x963 x964 x965 x966 x967 x968 x969 x970 x971 x972 x973 x974 x975 x976 x977 x978 x979 x980 x981 x982 x983 x984 x985 x986 x987 x988 x989 x990 x991 x992 x993 x994 x995 x996 x997 x998 x999 
+			)
+		 (list x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 x31 x32 x33 x34 x35 x36 x37 x38 x39 x40 x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 x51 x52 x53 x54 x55 x56 x57 x58 x59 x60 x61 x62 x63 x64 x65 x66 x67 x68 x69 x70 x71 x72 x73 x74 x75 x76 x77 x78 x79 x80 x81 x82 x83 x84 x85 x86 x87 x88 x89 x90 x91 x92 x93 x94 x95 x96 x97 x98 x99 
+		       x100 x101 x102 x103 x104 x105 x106 x107 x108 x109 x110 x111 x112 x113 x114 x115 x116 x117 x118 x119 x120 x121 x122 x123 x124 x125 x126 x127 x128 x129 x130 x131 x132 x133 x134 x135 x136 x137 x138 x139 x140 x141 x142 x143 x144 x145 x146 x147 x148 x149 x150 x151 x152 x153 x154 x155 x156 x157 x158 x159 x160 x161 x162 x163 x164 x165 x166 x167 x168 x169 x170 x171 x172 x173 x174 x175 x176 x177 x178 x179 x180 x181 x182 x183 x184 x185 x186 x187 x188 x189 x190 x191 x192 x193 x194 x195 x196 x197 x198 x199 
+		       x200 x201 x202 x203 x204 x205 x206 x207 x208 x209 x210 x211 x212 x213 x214 x215 x216 x217 x218 x219 x220 x221 x222 x223 x224 x225 x226 x227 x228 x229 x230 x231 x232 x233 x234 x235 x236 x237 x238 x239 x240 x241 x242 x243 x244 x245 x246 x247 x248 x249 x250 x251 x252 x253 x254 x255 x256 x257 x258 x259 x260 x261 x262 x263 x264 x265 x266 x267 x268 x269 x270 x271 x272 x273 x274 x275 x276 x277 x278 x279 x280 x281 x282 x283 x284 x285 x286 x287 x288 x289 x290 x291 x292 x293 x294 x295 x296 x297 x298 x299 
+		       x300 x301 x302 x303 x304 x305 x306 x307 x308 x309 x310 x311 x312 x313 x314 x315 x316 x317 x318 x319 x320 x321 x322 x323 x324 x325 x326 x327 x328 x329 x330 x331 x332 x333 x334 x335 x336 x337 x338 x339 x340 x341 x342 x343 x344 x345 x346 x347 x348 x349 x350 x351 x352 x353 x354 x355 x356 x357 x358 x359 x360 x361 x362 x363 x364 x365 x366 x367 x368 x369 x370 x371 x372 x373 x374 x375 x376 x377 x378 x379 x380 x381 x382 x383 x384 x385 x386 x387 x388 x389 x390 x391 x392 x393 x394 x395 x396 x397 x398 x399 
+		       x400 x401 x402 x403 x404 x405 x406 x407 x408 x409 x410 x411 x412 x413 x414 x415 x416 x417 x418 x419 x420 x421 x422 x423 x424 x425 x426 x427 x428 x429 x430 x431 x432 x433 x434 x435 x436 x437 x438 x439 x440 x441 x442 x443 x444 x445 x446 x447 x448 x449 x450 x451 x452 x453 x454 x455 x456 x457 x458 x459 x460 x461 x462 x463 x464 x465 x466 x467 x468 x469 x470 x471 x472 x473 x474 x475 x476 x477 x478 x479 x480 x481 x482 x483 x484 x485 x486 x487 x488 x489 x490 x491 x492 x493 x494 x495 x496 x497 x498 x499 
+		       x500 x501 x502 x503 x504 x505 x506 x507 x508 x509 x510 x511 x512 x513 x514 x515 x516 x517 x518 x519 x520 x521 x522 x523 x524 x525 x526 x527 x528 x529 x530 x531 x532 x533 x534 x535 x536 x537 x538 x539 x540 x541 x542 x543 x544 x545 x546 x547 x548 x549 x550 x551 x552 x553 x554 x555 x556 x557 x558 x559 x560 x561 x562 x563 x564 x565 x566 x567 x568 x569 x570 x571 x572 x573 x574 x575 x576 x577 x578 x579 x580 x581 x582 x583 x584 x585 x586 x587 x588 x589 x590 x591 x592 x593 x594 x595 x596 x597 x598 x599 
+		       x600 x601 x602 x603 x604 x605 x606 x607 x608 x609 x610 x611 x612 x613 x614 x615 x616 x617 x618 x619 x620 x621 x622 x623 x624 x625 x626 x627 x628 x629 x630 x631 x632 x633 x634 x635 x636 x637 x638 x639 x640 x641 x642 x643 x644 x645 x646 x647 x648 x649 x650 x651 x652 x653 x654 x655 x656 x657 x658 x659 x660 x661 x662 x663 x664 x665 x666 x667 x668 x669 x670 x671 x672 x673 x674 x675 x676 x677 x678 x679 x680 x681 x682 x683 x684 x685 x686 x687 x688 x689 x690 x691 x692 x693 x694 x695 x696 x697 x698 x699 
+		       x700 x701 x702 x703 x704 x705 x706 x707 x708 x709 x710 x711 x712 x713 x714 x715 x716 x717 x718 x719 x720 x721 x722 x723 x724 x725 x726 x727 x728 x729 x730 x731 x732 x733 x734 x735 x736 x737 x738 x739 x740 x741 x742 x743 x744 x745 x746 x747 x748 x749 x750 x751 x752 x753 x754 x755 x756 x757 x758 x759 x760 x761 x762 x763 x764 x765 x766 x767 x768 x769 x770 x771 x772 x773 x774 x775 x776 x777 x778 x779 x780 x781 x782 x783 x784 x785 x786 x787 x788 x789 x790 x791 x792 x793 x794 x795 x796 x797 x798 x799 
+		       x800 x801 x802 x803 x804 x805 x806 x807 x808 x809 x810 x811 x812 x813 x814 x815 x816 x817 x818 x819 x820 x821 x822 x823 x824 x825 x826 x827 x828 x829 x830 x831 x832 x833 x834 x835 x836 x837 x838 x839 x840 x841 x842 x843 x844 x845 x846 x847 x848 x849 x850 x851 x852 x853 x854 x855 x856 x857 x858 x859 x860 x861 x862 x863 x864 x865 x866 x867 x868 x869 x870 x871 x872 x873 x874 x875 x876 x877 x878 x879 x880 x881 x882 x883 x884 x885 x886 x887 x888 x889 x890 x891 x892 x893 x894 x895 x896 x897 x898 x899 
+		       x900 x901 x902 x903 x904 x905 x906 x907 x908 x909 x910 x911 x912 x913 x914 x915 x916 x917 x918 x919 x920 x921 x922 x923 x924 x925 x926 x927 x928 x929 x930 x931 x932 x933 x934 x935 x936 x937 x938 x939 x940 x941 x942 x943 x944 x945 x946 x947 x948 x949 x950 x951 x952 x953 x954 x955 x956 x957 x958 x959 x960 x961 x962 x963 x964 x965 x966 x967 x968 x969 x970 x971 x972 x973 x974 x975 x976 x977 x978 x979 x980 x981 x982 x983 x984 x985 x986 x987 x988 x989 x990 x991 x992 x993 x994 x995 x996 x997 x998 x999 
+		       ))))
+	(f 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 
+	   100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 
+	   200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 
+	   300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 
+	   400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 
+	   500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 
+	   600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 
+	   700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 
+	   800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 
+	   900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 
+	   )))
+
+(test "* 1" = 6 (* 1 2 3))
+(test "* 2" = (* 214760876 10) 2147608760)
+(test "* 3" = (* 47123 46039) 2169495797)
+
+(test "internal define" equal? '(20 20 20 20)
+      (list (let ()
+	      (define a 5)
+	      (define b 15)
+	      (+ a b))
+      
+	    (let ((b 10))
+	      (define (a) b)
+	      (define b 20)
+	      (a))
+
+	    (let ((b 10))
+	      (define b 20)
+	      (define (a) b)
+	      (a))
+
+	    (let ((b 10)
+		  (a (lambda () 20))
+		  (define (lambda args 30)))
+	      (define b 40)
+	      (define (a) b)
+	      (a))))
+
+(define (identity x) x)		; handy for preventing inlining
+
+(let ((port (make-port #f -1 0 #f 0 (make-code-vector 1024 25) 0 1023 #f)))
+  (set-port-index! port 0)
+  (test "read-char0" = 25 (char->ascii (read-char port)))
+  (test "read-char1" = 25 (char->ascii ((identity read-char) port))))
+
+(test "apply" equal? '(1 2 3 4) (apply list 1 2 '(3 4)))
+
+(test "char<->integer" eq? #\a (integer->char (char->integer #\a)))
+
+(test "number->string" equal?
+      '("12" "14" "-12" "-14")
+      (list (number->string 12)
+	    (number->string 12 8)
+	    (number->string -12)
+	    (number->string -12 8)))
+
+(test "string->number" equal?
+      '(12 10 -12 -10)
+      (list (string->number "12")
+	    (string->number "12" 8)
+	    (string->number "-12")
+	    (string->number "-12" 8)))
+
+(test "lap" equal? #f ((lap #f () (protocol 0) (false) (return))))
+(let ((q (make-queue)))
+  (enqueue! q 'a)
+  (test "q" eq? 'a (dequeue! q)))
+
+(test "random" <= 0 ((make-random 7)))
+
+(test "sort" equal? '(1 2 3 3) (sort-list '(2 3 1 3) <))
+
+(test "bigbit" = (expt 2 100) (arithmetic-shift 1 100))
+
+(test "format" string=? "x(1 2)" (format #f "x~s" '(1 2)))
+
+(test "fancy input ports" equal? '(3 5)
+      (let ((p1 (make-tracking-input-port (make-string-input-port "
+
+
+    2 3"))))
+	(read p1)
+	(list (current-row p1) (current-column p1))))
+
+(test "fancy output ports" equal? '(1 4 "8
+   9")
+      (let* ((r 0)
+	     (c 0)
+	     (s (call-with-string-output-port
+		 (lambda (out)
+		   (let ((out (make-tracking-output-port out)))
+		     (write 8 out)
+		     (fresh-line out)
+		     (fresh-line out)
+		     (display "   9" out)
+		     (set! r (current-row out))
+		     (set! c (current-column out))
+		     (close-output-port out))))))
+	(list r c s)))
+
+(test "write-one-line" string=? "(1 2 3 4 5"
+      (call-with-string-output-port
+       (lambda (out)
+	 (write-one-line out
+			 10
+			 (lambda (out)
+			   (display '(1 2 3 4 5 6) out))))))
+
+(test "destructure" eq? 'a (destructure (((x (y) z) '(b (a) c))) y))
+
+(test "array" eq? 'a
+      (let ((a (make-array 'b 3 4)))
+	(array-set! a 'a 1 2)
+	(array-ref a 1 2)))
+
+(test "R4RS delay" = 3 (letrec ((p (delay (if c 3 (begin (set! c #t)
+							 (+ (force p) 1)))))
+				(c #f))
+			 (force p)))
+
+(test "receive" equal? '(a b) (receive stuff (values 'a 'b) stuff))
+(let ((z '(a "b" 3 #t)))
+  (test "dump" equal? z
+	(let ((q (make-queue)))
+	  (dump z (lambda (c) (enqueue! q c)) -1)
+	  (restore (lambda () (dequeue! q))))))
+(let ((r 0)
+      (l1 (make-lock))
+      (l2 (make-lock))
+      (ph (make-placeholder)))
+  (let ((f (lambda (i lock)
+	     (spawn (lambda ()
+		      (let ((v (placeholder-value ph)))
+			(with-interrupts-inhibited
+			 (lambda ()
+			   (set! r (+ i v r))))
+			(release-lock lock)))))))
+    (obtain-lock l1)
+    (obtain-lock l2)
+    (f 1 l1)
+    (f 2 l2)
+    (placeholder-set! ph 10)
+    (obtain-lock l1)
+    (obtain-lock l2)
+    (test "placeholders" = r 23)))
+
+(test "explode" equal? 'ab3 (implode (explode 'ab3)))
+
+(test "get/put" equal? 'a (begin (put 'foo 'prop 'a)
+				 (get 'foo 'prop)))
+
+(test "search-trees" eq? 'a
+      (let ((t (make-search-tree = <)))
+	(search-tree-set! t 3 'b)
+	(search-tree-set! t 4 'a)
+	(search-tree-set! t 5 'c)
+	(search-tree-ref t 4)))
+
+(test "sockets" equal? '(303 202 101)
+      (let ((server (open-socket))
+	    (name (get-host-name)))
+	(spawn (lambda ()
+		 (let loop ((i 100))
+		   (if (= i 400)
+		       (close-socket server)
+		       (call-with-values (lambda ()
+					   (socket-accept server))
+					 (lambda (in out)
+					   (spawn (lambda ()
+						    (write (+ i (read in)) out)
+						    (write-char #\space out)
+						    (close-input-port in)
+						    (close-output-port out)))
+					   (loop (+ i 100))))))))
+	(let loop ((i 1) (result '()))
+	  (if (= i 4)
+	      result
+	      (call-with-values
+	       (lambda ()
+		 (socket-client name (socket-port-number server)))
+	       (lambda (in out)
+		 (write i out)
+		 (write-char #\space out)
+		 (let ((result (cons (read in) result)))
+		   (close-input-port in)
+		   (close-output-port out)
+		   (loop (+ i 1) result))))))))
+
+))))
+
+(load-package 'foo)
+
+(load-package 'floatnums)
+
+(in 'foo '(run (let* ((one (exact->inexact 1))
+		      (three (exact->inexact 3))
+		      (third (/ one three))
+		      (xthird (inexact->exact third)))
+		 (test "float" eq? #f (= 1/3 xthird))
+		 (test "exact<->inexact" = third (exact->inexact xthird)))))
+
+
+; All done.
+
+(if (in 'testing '(run (lost?)))
+    (display "Some tests failed.")
+    (display "All tests succeeded."))
+(newline)
+
+(define (done)
+  (exit (if (in 'testing '(run (lost?))) 1 0)))
diff --git a/scheme/debug/describe.scm b/scheme/debug/describe.scm
new file mode 100644
index 0000000..66e0c64
--- /dev/null
+++ b/scheme/debug/describe.scm
@@ -0,0 +1,41 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+(define (describe x)
+  (if (and (stob? x)
+	   (< (stob-type x) least-b-vector-type))
+      (let ((tag (string-append (number->string x) ": "))
+	    (len (bytes->cells (stob-length-in-bytes x))))
+	(do ((i -1 (+ i 1)))
+	    ((= i len))
+	  (describe-1 (stob-ref x i) tag)))
+      (describe-1 x "")))
+
+
+
+(define (describe-1 x addr)
+  (cond ((fixnum? x) (display " fixnum ") (write (extract-fixnum x)))
+	((header? x)
+	 (display addr)
+	 (if (immutable-header? x)
+	     (display " immutable"))
+	 (display " header ")
+	 (let ((type (header-type x)))
+	   (if (< type stob-count)
+	       (write (vector-ref stob type))
+	       (write type)))
+	 (display " ")
+	 (write (header-length-in-bytes x)))
+	((immediate? x)
+	 (cond (else
+		(display " immediate ")
+		(let ((type (immediate-type x)))
+		  (if (< type imm-count)
+		      (write (vector-ref imm type))
+		      (write type)))
+		(display " ")
+		(write (immediate-info x)))))
+	((stob? x)
+	 (display " stob ") (write x))
+	(else (display " ? ") (write x)))
+  (newline))
diff --git a/scheme/debug/fact.scm b/scheme/debug/fact.scm
new file mode 100644
index 0000000..2b12ea0
--- /dev/null
+++ b/scheme/debug/fact.scm
@@ -0,0 +1,9 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; don't copyright this, silly shell script
+
+
+(define (fact n)
+  (if (= n 0)
+      1
+      (* n (fact (- n 1)))))
diff --git a/scheme/debug/fix-low.scm b/scheme/debug/fix-low.scm
new file mode 100644
index 0000000..6fe9376
--- /dev/null
+++ b/scheme/debug/fix-low.scm
@@ -0,0 +1,72 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+(define-structure low-structures low-structures-interface
+  ;; Flatloaded
+  (open ))
+
+(define ascii (structure-ref built-in-structures ascii))
+(define signals (structure-ref built-in-structures signals))
+(define loopholes (structure-ref built-in-structures loopholes))
+(define escapes (structure-ref built-in-structures escapes))
+(define vm-exposure (structure-ref built-in-structures vm-exposure))
+
+; (define-structure locations locations-interface
+;   (open scheme-level-2 ...))
+(define locations (structure-ref built-in-structures locations))
+
+(define closures (structure-ref built-in-structures closures))
+(define bitwise (structure-ref built-in-structures bitwise))
+
+;; For initial system
+(define write-images (structure-ref built-in-structures write-images))
+(define structure-refs (structure-ref built-in-structures structure-refs))
+(define low-level (structure-ref built-in-structures low-level))
+
+;; For compiler
+(define features (structure-ref built-in-structures features))
+(define code-vectors (structure-ref built-in-structures code-vectors))
+(define source-file-names
+  (structure-ref built-in-structures source-file-names))
+
+(define true-scheme (structure-ref built-in-structures scheme))
+
+
+(define-structure scheme-level-0 scheme-level-0-interface
+  (open true-scheme
+	primitives		; only for extended-number?
+	structure-refs)
+  (access true-scheme)
+  (files level-0))
+
+(define-structure silly (export reverse-list->string)
+  (open true-scheme)
+  (begin (define (reverse-list->string l n)
+	   (list->string (reverse l)))))
+
+(define-structure cont-primitives
+    (export make-continuation
+	    continuation-length
+	    continuation-ref
+	    continuation-set!
+	    continuation?)
+  (open (structure-ref built-in-structures primitives)))
+
+(define-structures ((primitives primitives-interface)
+		    (primitives-internal (export maybe-handle-interrupt
+						 raise-exception
+						 get-exception-handler
+						 ?start)))
+  (open true-scheme
+        cont-primitives
+        (structure-ref built-in-structures bitwise)
+        (structure-ref built-in-structures records)
+        (structure-ref built-in-structures signals)
+        (structure-ref built-in-structures features)
+        (structure-ref built-in-structures templates)
+	)
+  (files ("../alt" primitives)
+	 ("../alt" weak)))
+
+; How about signals?
+
diff --git a/scheme/debug/for-debugging.scm b/scheme/debug/for-debugging.scm
new file mode 100644
index 0000000..4e8a840
--- /dev/null
+++ b/scheme/debug/for-debugging.scm
@@ -0,0 +1,59 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; --------------------
+
+; Fake interrupt and exception system.
+; This needs to be reconciled with alt/primitives.scm.
+
+(define (with-exceptions thunk)
+  (with-handler
+       (lambda (c punt)
+	 (cond ((and (exception? c)
+		     (procedure? (get-exception-handler)))
+		(handle-exception-carefully c))
+	       ((interrupt? c)
+		(if (not (deal-with-interrupt c))
+		    (punt)))
+	       ;; ((vm-return? c)
+	       ;;  (vm-return (cadr c)))
+	       (else
+		(punt))))
+     thunk))
+
+(define (handle-exception-carefully c)
+  (display "(Exception: ") (write c) (display ")") (newline)
+  (noting-exceptional-context c
+    (lambda ()
+      (raise-exception (exception-opcode c)
+		       (exception-arguments c)))))
+
+(define (noting-exceptional-context c thunk)
+  (call-with-current-continuation
+    (lambda (k)
+      ;; Save for future inspection, just in case.
+      (set! *exceptional-context* (cons c k))
+      (thunk))))
+
+(define *exceptional-context* #f)
+
+(define (deal-with-interrupt c)
+  (noting-exceptional-context c
+    (lambda ()
+      (maybe-handle-interrupt
+       (if (and (pair? (cdr c)) (integer? (cadr c)))
+	   (cadr c)
+	   (enum interrupt keyboard))))))
+
+; (define (poll-for-interrupts) ...)
+
+
+; Get the whole thing started
+
+(define (?start-with-exceptions entry-point arg)
+  (with-exceptions
+   (lambda ()
+     (?start entry-point arg))))
+
+(define (in struct form)
+  (eval form (structure-package struct)))
diff --git a/scheme/debug/graph.scm b/scheme/debug/graph.scm
new file mode 100644
index 0000000..9c74e98
--- /dev/null
+++ b/scheme/debug/graph.scm
@@ -0,0 +1,142 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Code to print out module dependencies in a format readable by the
+; graph layout program AT&T DOT Release 1.0. (for information on DOT call
+; the AT&T Software Technology Center Common Support Hotline (908) 582-7009)
+
+; Follow link script up to the actual linking
+;(load-configuration "scheme/interfaces.scm") 
+;(load-configuration "scheme/packages.scm") 
+;(flatload initial-structures) 
+;(load "build/initial.scm")
+;
+; Load this and run it
+;(load "scheme/debug/graph.scm")
+;(dependency-graph (initial-packages)
+; (map structure-package (list scheme-level-1 scheme-level-0))
+; "graph.dot")
+;
+; Run the graph layout program
+; setenv SDE_LICENSE_FILE /pls/local/lib/DOT/LICENSE.dot
+; /pls/local/lib/DOT/dot -Tps graph.dot -o graph.ps
+
+; Returns a list of the packages in the initial system.
+
+(define (initial-packages)
+  (map (lambda (p)
+	 (structure-package (cdr p)))
+       (append (struct-list scheme
+			    environments
+			    module-system
+			    ensures-loaded
+			    packages
+			    packages-internal)
+	       (desirable-structures))))
+
+; Write the dependency graph found by rooting from PACKAGES to FILENAME.
+; Packages in the list IGNORE are ignored.
+;
+; Each configuration file's packages are done as a separate subgraph.
+
+(define (dependency-graph packages ignore filename)
+  (call-with-output-file filename
+    (lambda (out)
+      (display prelude out)
+      (newline out)
+      (let ((subgraphs (do-next-package packages ignore '() ignore out)))
+	(for-each (lambda (sub)
+		    (note-subgraph sub out))
+		  subgraphs)
+	(display "}" out)
+	(newline out)))))
+
+; Do the first not-yet-done package, returning the subgraphs if there are
+; no packages left.  TO-DO, DONE, and IGNORE are lists of packages.
+; SUBGRAPHS is an a-list indexed by source-file-name.
+
+(define (do-next-package to-do done subgraphs ignore out)
+  (let loop ((to-do to-do))
+    (if (null? to-do)
+	subgraphs
+	(let ((package (car to-do)))
+	  (if (memq package done)
+	      (loop (cdr to-do))
+	      (do-package package (cdr to-do) (cons package done)
+			  subgraphs ignore out))))))
+
+; Find the correct subgraph, add PACKAGE to it, note any edges, and continue
+; with the rest of the graph.
+
+(define (do-package package to-do done subgraphs ignore out)
+  (let* ((source-file (package-file-name package))
+	 (opens (map structure-package
+		     ((package-opens-thunk package))))
+	 (old-subgraph (assq source-file subgraphs))
+	 (subgraph (or old-subgraph
+		       (list source-file))))
+    (set-cdr! subgraph (cons package (cdr subgraph)))
+    (do-edges package opens source-file ignore out)
+    (do-next-package (append opens to-do)
+		     done
+		     (if old-subgraph
+			 subgraphs
+			 (cons subgraph subgraphs))
+		     ignore
+		     out)))
+
+; Add an edge from each package in OPENS to PACKAGE, provided that the
+; two were defined in the same file.
+
+(define (do-edges package opens source-file ignore out)
+  (let loop ((opens opens) (done ignore))
+    (if (not (null? opens))
+	(loop (cdr opens)
+	      (let ((p (car opens)))
+		(if (or (memq p done)
+			(not (string=? source-file (package-file-name p))))
+		    done
+		    (begin
+		      (note-edge p package out)
+		      (cons p done))))))))
+
+; Writing out the package name as a string (actually, its the name of
+; the first of the package's clients).
+
+(define (package-name package out)
+  (let ((clients (population->list (package-clients package))))
+    (write-char #\" out)
+    (display (structure-name (car clients)) out)
+    (write-char #\" out)))
+
+; Header for DOT files
+
+(define prelude
+  "digraph G {
+   orientation=landscape;
+   size =\"10,7.5\";
+   page =\"8.5,11\";
+   ratio =fill;")
+
+; Writing out edges and subgraphs
+
+(define (note-edge from to out)
+  (display "   " out)
+  (package-name from out)
+  (display " -> " out)
+  (package-name to out)
+  (write-char #\; out)
+  (newline out))
+
+(define (note-subgraph subgraph out)
+  (display "   subgraph \"cluster_" out)
+  (display (car subgraph) out)
+  (display "\" { label=\"" out)
+  (display (car subgraph) out)
+  (display "\"; " out)
+  (for-each (lambda (p)
+	      (package-name p out)
+	      (display "; " out))
+	    (cdr subgraph))
+  (display "}" out)
+  (newline out))
+
diff --git a/scheme/debug/level-0.scm b/scheme/debug/level-0.scm
new file mode 100644
index 0000000..39e52cd
--- /dev/null
+++ b/scheme/debug/level-0.scm
@@ -0,0 +1,30 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Redefinitions of some usual Scheme things so as to make the new
+; exception system kick in when it needs to.
+
+(define (number? n)
+  (or ((structure-ref true-scheme number?) n)
+      (extended-number? n)))
+
+;(define (integer? n)
+;  (if ((structure-ref true-scheme number?) n)
+;      ((structure-ref true-scheme integer?) n)
+;      (and (extended-number? n)
+;           ... raise exception ...)))
+
+(define (+ x y) ((structure-ref true-scheme +) x y))
+(define (* x y) ((structure-ref true-scheme *) x y))
+(define (- x y) ((structure-ref true-scheme -) x y))
+(define (/ x y) ((structure-ref true-scheme /) x y))
+(define (= x y) ((structure-ref true-scheme =) x y))
+(define (< x y) ((structure-ref true-scheme <) x y))
+(define (make-vector x y) ((structure-ref true-scheme make-vector) x y))
+(define (make-string x y) ((structure-ref true-scheme make-string) x y))
+(define (apply x y) ((structure-ref true-scheme apply) x y))
+
+(define (read-char x) ((structure-ref true-scheme read-char) x))
+(define (peek-char x) ((structure-ref true-scheme peek-char) x))
+(define (char-ready? x) ((structure-ref true-scheme char-ready?) x))
+(define (write-char x y) ((structure-ref true-scheme write-char) x y))
diff --git a/scheme/debug/link-debug.scm b/scheme/debug/link-debug.scm
new file mode 100644
index 0000000..d9fbbb5
--- /dev/null
+++ b/scheme/debug/link-debug.scm
@@ -0,0 +1,36 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+
+
+; Stuff for debugging new images:
+
+(define (ev form package)
+  (invoke-template (compile-form form package)
+		   (package-uid package)))
+
+; If desired, this definition of invoke-template can be replaced by
+; something that starts up a different virtual machine.
+
+(define (invoke-template template env . args)
+  (apply (make-closure template env)
+	 args))
+
+; Utility for tracking down uses of variables
+
+(define (who-uses name proc)
+  (let recur ((tem (closure-template proc))
+              (path '()))
+    (let loop ((i 0))
+      (if (< i (template-length tem))
+          (let ((thing (template-ref tem i))
+                (down (lambda (tem)
+                        (recur tem (cons (or (template-ref tem 1) i) path)))))
+            (cond ((template? thing)
+                   (down thing))
+                  ((location? thing)
+                   (if (eq? (location-name thing) name)
+                       (begin (write path) (newline))))
+                  ((closure? thing)
+                   (down (closure-template thing))))
+            (loop (+ i 1)))))))
diff --git a/scheme/debug/linker.scm b/scheme/debug/linker.scm
new file mode 100644
index 0000000..84fe02a
--- /dev/null
+++ b/scheme/debug/linker.scm
@@ -0,0 +1,34 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+(define (link-simple-system filename resumer-exp . structs)
+  (link-system structs (lambda () resumer-exp) filename))
+
+(define (link-reified-system some filename make-resumer-exp . structs)
+  (link-system (append structs (map cdr some))
+	       (lambda ()
+		 (display "Reifying") (newline)
+		 `(,make-resumer-exp
+		   (lambda ()
+		     ,(reify-structures some
+					(lambda (loc) loc)
+					`(lambda (loc) loc)))))
+	       filename))
+
+
+(define (link-system structs make-resumer filename)
+  (for-each ensure-loaded structs)
+  (let* ((p (make-simple-package structs eval #f))
+	 (r (eval (make-resumer) p)))
+    ;; (check-package p)
+    r))
+
+;(define (check-package p)
+;  (let ((names (undefined-variables p)))
+;    (if (not (null? names))
+;        (begin (display "Undefined: ") 
+;               (write names) (newline)))))
+
+(define-syntax struct-list
+  (syntax-rules ()
+    ((struct-list name ...) (list (cons 'name name) ...))))
diff --git a/scheme/debug/low-test-packages.scm b/scheme/debug/low-test-packages.scm
new file mode 100644
index 0000000..ee51203
--- /dev/null
+++ b/scheme/debug/low-test-packages.scm
@@ -0,0 +1,7 @@
+; no copyright
+
+; (link-simple-system '(debug low-test) 'start low-test-system)
+
+(define-structure low-test-system (export start)
+  (define-all-operators)
+  (files low-test))
diff --git a/scheme/debug/low-test.scm b/scheme/debug/low-test.scm
new file mode 100644
index 0000000..3de71af
--- /dev/null
+++ b/scheme/debug/low-test.scm
@@ -0,0 +1,312 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Tests for many of the primitives, both inlined and close-compiled.
+
+; This prints `Hello' three times and then the first command argument, if any,
+; and finally reads a line from standard input and prints it to standard output.
+
+(define (start arg in out error-out)
+  (call-with-values
+    (lambda ()
+      (values "H" "e" "ll" "o" " "))
+    (lambda (h e ll o sp)
+      (write-string h out)
+      (write-string e out)
+      (write-string ll out)
+      (write-string o out)
+      (write-string sp out)))
+  (call-with-values
+    (lambda ()
+      (apply values "H" "e" '("ll" "o" " ")))
+    (lambda (h e ll o sp)
+      (write-string h out)
+      (write-string e out)
+      (write-string ll out)
+      (write-string o out)
+      (write-string sp out)))
+  (call-with-values
+    (lambda ()
+      (values "H" "e" "ll" "o" " "))
+    (lambda (h e . more)
+      (write-string h out)
+      (write-string e out)
+      (letrec ((loop (lambda (more)
+		       (if (eq? '() more)
+			   0
+			   (begin
+			     (write-string (car more) out)
+			     (loop (cdr more)))))))
+	(loop more))))
+  (if (vector? arg)
+      (if (< 0 (vector-length arg))
+	  (write-string (vector-ref arg 0) out)))
+  (newline out)
+
+  (bool-test (= 1 1) "(= 1 1)" #t out)
+  (bool-test (= 1 2) "(= 1 2)" #f out)
+  (bool-test (= 1 1 1) "(= 1 1 1)" #t out)
+  (bool-test (= 1 2 3) "(= 1 2 3)" #f out)
+  (bool-test (= 1 1 1 3) "(= 1 1 1 3)" #f out)
+  (bool-test (= 1 1 1 1) "(= 1 1 1 1)" #t out)
+  (bool-test (= 1 1 2 3) "(= 1 1 2 3)" #f out)
+  (bool-test (= 1 1 1 3) "(= 1 1 1 3)" #f out)
+  ((lambda (=)
+     (bool-test (= 1 1) "(= 1 1)" #t out)
+     (bool-test (= 1 2) "(= 1 2)" #f out)
+     (bool-test (= 1 1 1) "(= 1 1 1)" #t out)
+     (bool-test (= 1 2 3) "(= 1 2 3)" #f out)
+     (bool-test (= 1 1 3) "(= 1 1 3)" #f out)
+     (bool-test (= 1 1 1 3) "(= 1 1 1 3)" #f out)
+     (bool-test (= 1 1 1 1) "(= 1 1 1 1)" #t out)
+     (bool-test (= 1 1 2 3) "(= 1 1 2 3)" #f out)
+     (bool-test (= 1 1 1 3) "(= 1 1 1 3)" #f out))
+   =)
+  (bool-test (< 1 1) "(< 1 1)" #f out)
+  (bool-test (< 1 2) "(< 1 2)" #t out)
+  (bool-test (< 1 1 1) "(< 1 1 1)" #f out)
+  (bool-test (< 1 2 3) "(< 1 2 3)" #t out)
+  (bool-test (< 1 2 2) "(< 1 2 2)" #f out)
+  ((lambda (<)
+     (bool-test (< 1 1) "(< 1 1)" #f out)
+     (bool-test (< 1 2) "(< 1 2)" #t out)
+     (bool-test (< 1 1 1) "(< 1 1 1)" #f out)
+     (bool-test (< 1 2 3) "(< 1 2 3)" #t out)
+     (bool-test (< 1 2 2) "(< 1 2 2)" #f out))
+   <)
+  (bool-test (<= 1 1) "(<= 1 1)" #t out)
+  (bool-test (<= 1 2) "(<= 1 2)" #t out)
+  (bool-test (<= 2 1) "(<= 2 1)" #f out)
+  (bool-test (<= 1 1 1) "(<= 1 1 1)" #t out)
+  (bool-test (<= 1 2 3) "(<= 1 2 3)" #t out)
+  (bool-test (<= 1 2 2) "(<= 1 2 2)" #t out)
+  (bool-test (<= 1 2 1) "(<= 1 2 1)" #f out)
+  ((lambda (<=)
+     (bool-test (<= 1 1) "(<= 1 1)" #t out)
+     (bool-test (<= 1 2) "(<= 1 2)" #t out)
+     (bool-test (<= 2 1) "(<= 2 1)" #f out)
+     (bool-test (<= 1 1 1) "(<= 1 1 1)" #t out)
+     (bool-test (<= 1 2 3) "(<= 1 2 3)" #t out)
+     (bool-test (<= 1 2 2) "(<= 1 2 2)" #t out)
+     (bool-test (<= 1 2 1) "(<= 1 2 1)" #f out))
+   <=)
+  (bool-test (> 1 1) "(> 1 1)" #f out)
+  (bool-test (> 2 1) "(> 2 1)" #t out)
+  (bool-test (> 1 1 1) "(> 1 1 1)" #f out)
+  (bool-test (> 3 2 1) "(> 3 2 1)" #t out)
+  (bool-test (> 2 1 1) "(> 2 1 1)" #f out)
+  ((lambda (>)
+     (bool-test (> 1 1) "(> 1 1)" #f out)
+     (bool-test (> 2 1) "(> 2 1)" #t out)
+     (bool-test (> 1 1 1) "(> 1 1 1)" #f out)
+     (bool-test (> 3 2 1) "(> 3 2 1)" #t out)
+     (bool-test (> 2 1 1) "(> 2 1 1)" #f out))
+   >)
+  (bool-test (>= 1 1) "(>= 1 1)" #t out)
+  (bool-test (>= 2 1) "(>= 2 1)" #t out)
+  (bool-test (>= 1 2) "(>= 1 2)" #f out)
+  (bool-test (>= 1 1 1) "(>= 1 1 1)" #t out)
+  (bool-test (>= 3 2 1) "(>= 3 2 1)" #t out)
+  (bool-test (>= 2 1 1) "(>= 2 1 1)" #t out)
+  (bool-test (>= 2 1 2) "(>= 2 1 2)" #f out)
+  ((lambda (>=)
+     (bool-test (>= 1 1) "(>= 1 1)" #t out)
+     (bool-test (>= 2 1) "(>= 2 1)" #t out)
+     (bool-test (>= 1 2) "(>= 1 2)" #f out)
+     (bool-test (>= 1 1 1) "(>= 1 1 1)" #t out)
+     (bool-test (>= 3 2 1) "(>= 3 2 1)" #t out)
+     (bool-test (>= 2 1 1) "(>= 2 1 1)" #t out)
+     (bool-test (>= 2 1 2) "(>= 2 1 2)" #f out))
+   >=)
+  (arith-test (vector-length (make-vector 3)) "make-vector0" 3 out)
+  (arith-test (vector-length (make-vector 3 4)) "make-vector1" 3 out)
+  (arith-test (vector-ref (make-vector 3 4) 2) "make-vector2" 4 out)
+  ((lambda (make-vector)
+     (arith-test (vector-length (make-vector 3)) "make-vector3" 3 out)
+     (arith-test (vector-length (make-vector 3 4)) "make-vector4" 3 out)
+     (arith-test (vector-ref (make-vector 3 4) 2) "make-vector5" 4 out))
+   make-vector)
+  (arith-test (string-length (make-string 3)) "make-string0" 3 out)
+  (arith-test (string-length (make-string 3 #\a)) "make-string1" 3 out)
+  (arith-test (- (char->ascii (string-ref (make-string 3) 2))
+		 (char->ascii #\?))
+	      "make-string2" 0 out)
+  (arith-test (- (char->ascii (string-ref (make-string 3 #\a) 2))
+		 (char->ascii #\a))
+	      "make-string3" 0 out)
+  ((lambda (make-string)
+     (arith-test (string-length (make-string 3)) "make-string4" 3 out)
+     (arith-test (string-length (make-string 3 #\a)) "make-string5" 3 out)
+     (arith-test (- (char->ascii (string-ref (make-string 3) 2))
+		    (char->ascii #\?))
+		 "make-string6" 0 out)
+     (arith-test (- (char->ascii (string-ref (make-string 3 #\a) 2))
+		    (char->ascii #\a))
+		 "make-string7" 0 out))
+   make-string)
+  (arith-test (apply + '()) "(apply + '())" 0 out)
+  (arith-test (apply + '(1)) "(apply + '(1))" 1 out)
+  (arith-test (apply + 1 '()) "(apply + 1 '())" 1 out)
+  (arith-test (apply + '(1 2)) "(apply + '(1 2))" 3 out)
+  (arith-test (apply + 1 '(2)) "(apply + 1 '(2))" 3 out)
+  (arith-test (apply + 1 2 '()) "(apply + 1 2 '())" 3 out)
+  (arith-test (apply + '(1 2 3)) "(apply + '(1 2 3))" 6 out)
+  (arith-test (apply + 1 2 '(3)) "(apply + 1 2 '(3))" 6 out)
+  (bool-test (apply < '(1 2)) "(apply < '(1 2))" #t out)
+  (bool-test (apply < 1 '(2)) "(apply < 1 '(2))" #t out)
+  (bool-test (apply < 1 2 '()) "(apply < 1 2 '())" #t out)
+  (bool-test (apply < '(1 2 3)) "(apply < '(1 2 3))" #t out)
+  (bool-test (apply < 1 2 '(3)) "(apply < 1 2 '(3))" #t out)
+  (arith-test (apply apply (list + '(1 2 3)))
+	      "(apply apply (list + '(1 2 3)))" 6 out)
+  (arith-test (apply apply (list + 1 2 '(3)))
+	      "(apply apply (list + 1 2 '(3)))" 6 out)
+  (arith-test (apply apply (list + 1 2 3 '()))
+	      "(apply apply (list + 1 2 3 '()))" 6 out)
+  (arith-test (apply apply + 1 '(2 3 ())) "(apply apply + 1 '(2 3 ())" 6 out)
+  (arith-test (apply apply + 1 '(2 (3))) "(apply apply + 1 '(2 3 ())" 6 out)
+  (arith-test (apply apply + 1 2 3 '(())) "(apply + 1 2 3 '(()))" 6 out)
+  ((lambda (apply)
+     (arith-test (apply + '(1 2 3)) "(apply + '(1 2 3))" 6 out)
+     (arith-test (apply + 1 2 '(3)) "(apply + 1 2 '(3))" 6 out)
+     (arith-test (apply apply (list + '(1 2 3)))
+		 "(apply apply (list + '(1 2 3)))" 6 out)
+     (arith-test (apply apply (list + 1 2 '(3)))
+		 "(apply apply (list + 1 2 '(3)))" 6 out)
+     (arith-test (apply apply (list + 1 2 3 '()))
+		 "(apply apply (list + 1 2 3 '()))" 6 out)
+     (arith-test (apply apply + 1 '(2 3 ())) "(apply apply + 1 '(2 3 ())" 6 out)
+     (arith-test (apply apply + 1 '(2 (3))) "(apply apply + 1 '(2 3 ())" 6 out)
+     (arith-test (apply apply + 1 2 3 '(())) "(apply + 1 2 3 '(()))" 6 out))
+   apply)
+  (arith-test (+) "(+)" 0 out)
+  (arith-test (+ 3) "(+ 3)" 3 out)
+  (arith-test (+ 3 4) "(+ 3 4)" 7 out)
+  (arith-test (+ 3 4 5) "(+ 3 4 5)" 12 out)
+  (arith-test (+ 1 2 3 4 5 6 7 8 9 10 -50) "(+ 1 2 3 ... 10 -50) = 5" 5 out)
+  ((lambda (+)
+     (arith-test (+) "(+) closed" 0 out)
+     (arith-test (+ 3) "(+ 3) closed" 3 out)
+     (arith-test (+ 3 4) "(+ 3 4) closed" 7 out)
+     (arith-test (+ 3 4 5) "(+ 3 4 5) closed" 12 out)
+     (arith-test (+ 3 4 5 6) "(+ 3 4 5 6) closed" 18 out)
+     (arith-test (+ 3 4 5 6 7) "(+ 3 4 5 6 7) closed" 25 out)
+     (arith-test (+ 1 2 3 4 5 6 7 8 9 10 -50) "(+ 1 2 3 ... 10 -50) = 5 closed" 5 out))
+   +)
+  (arith-test (*) "(*)" 1 out)
+  (arith-test (* 3) "(* 3)" 3 out)
+  (arith-test (* 3 4) "(* 3 4)" 12 out)
+  (arith-test (* 3 4 2) "(* 3 4 2)" 24 out)
+  ((lambda (*)
+     (arith-test (*) "(*)" 1 out)
+     (arith-test (* 3) "(* 3)" 3 out)
+     (arith-test (* 3 4) "(* 3 4)" 12 out)
+     (arith-test (* 3 4 2) "(* 3 4 2)" 24 out))
+   *)
+  (arith-test (- -3) "(- -3)" 3 out)
+  (arith-test (- 3 -4) "(- 3 -4)" 7 out)
+  ((lambda (-)
+     (arith-test (- -3) "(- -3)" 3 out)
+     (arith-test (- 3 -4) "(- 3 -4)" 7 out))
+   -)
+  (arith-test (/ 1) "(/ 1)" 1 out)
+  (arith-test (/ 12 4) "(/ 12 4)" 3 out)
+  ((lambda (/)
+     (arith-test (/ 1) "(/ 1)" 1 out)
+     (arith-test (/ 12 4) "(/ 12 4)" 3 out))
+   /)
+  (arith-test (bitwise-ior) "(bitwise-ior)" 0 out)
+  (arith-test (bitwise-ior 5) "(bitwise-ior 5)" 5 out)
+  (arith-test (bitwise-ior 5 3) "(bitwise-ior 5 3)" 7 out)
+  (arith-test (bitwise-ior 5 3 16) "(bitwise-ior 5 3 16)" 23 out)
+  (arith-test (bitwise-xor) "(bitwise-xor)" 0 out)
+  (arith-test (bitwise-xor 5) "(bitwise-xor 5)" 5 out)
+  (arith-test (bitwise-xor 5 3) "(bitwise-xor 5 3)" 6 out)
+  (arith-test (bitwise-xor 5 3 16) "(bitwise-xor 5 3 16)" 22 out)
+  (arith-test (- (bitwise-and)) "(- (bitwise-and))" 1 out)
+  (arith-test (bitwise-and 5) "(bitwise-and 5)" 5 out)
+  (arith-test (bitwise-and 7 3) "(bitwise-and 7 3)" 3 out)
+  (arith-test (bitwise-and 7 3 17) "(bitwise-and 7 3 17)" 1 out)
+  (apply write-string (read-string in) (cons out '()))
+  (newline out)
+  0)
+
+(define (length l n)
+  (if (eq? l '()) n (length (cdr l) (+ n 1))))
+
+(define (list . x) x)
+
+(define numbers
+  '#("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"
+     "10" "11" "12" "13" "14" "15" "16" "17" "18" "19"
+     "20" "21" "22" "23" "24" "25" "26" "27" "28" "29"))
+
+(define (number->string n)
+  (vector-ref numbers n))
+	 
+(define (arith-test n s a out)
+  (if (= n a)
+      #t
+      (begin
+	(write-string "Failure: " out)
+	(write-string s out)
+	(write-string " = " out)
+	(write-string (number->string n) out)
+	(write-string " and not " out)
+	(write-string (number->string a) out)
+	(newline out))))
+
+(define (bool-test n s a out)
+  (if (eq? n a)
+      #t
+      (begin
+	(write-string "Failure: " out)
+	(write-string s out)
+	(write-string " => " out)
+	(write-string (if n "#t" "#f") out)
+	(newline out))))
+
+(define (write-string string . channel-option)  ; test n-ary procedures
+  (channel-maybe-write string
+		       0
+		       (string-length string)
+		       (car channel-option)))
+
+(define (newline channel)
+  (write-string "
+" channel))
+
+(define (read-string in)
+  ((lambda (buffer)
+     (letrec ((loop (lambda (have)
+		      ((lambda (got)
+			 (if (eq? got (eof-object))
+			     "eof"
+			     ((lambda (len)
+				(if len
+				    ((lambda (string)
+				       (copy-string! buffer string len)
+				       string)
+				     (make-string len #\space))
+				    (loop (+ have got))))
+			      (has-newline buffer have got))))
+		       (channel-maybe-read buffer have (- 80 have) #f in)))))
+       (loop 0)))
+   (make-string 80 #\space)))
+
+(define (has-newline string start count)
+  (letrec ((loop (lambda (i)
+		   (if (= i count)
+		       #f
+		       (if (char=? #\newline
+				   (string-ref string (+ start i)))
+			   (+ start i)
+			   (loop (+ i 1)))))))
+    (loop 0)))
+
+(define (copy-string! from to count)
+  (letrec ((loop (lambda (i)
+		   (if (< i count)
+		       (begin
+			 (string-set! to i (string-ref from i))
+			 (loop (+ i 1)))))))
+    (loop 0)))
diff --git a/scheme/debug/mini-command.scm b/scheme/debug/mini-command.scm
new file mode 100644
index 0000000..3faf206
--- /dev/null
+++ b/scheme/debug/mini-command.scm
@@ -0,0 +1,67 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Miniature command processor.
+
+(define (command-processor ignore args)
+  (let ((in (current-input-port))
+	(out (current-output-port))
+	(err (current-error-port))
+	(batch? (member "batch" args)))
+    (let loop ()
+      ((call-with-current-continuation
+	 (lambda (go)
+	   (with-handler
+	       (lambda (c punt)
+		 (cond ((or (error? c) (interrupt? c))
+			(display-condition c err)
+			(go (if batch?
+				(lambda () 1)
+				loop)))
+		       ((warning? c)
+			(display-condition c err))
+		       (else (punt))))
+	     (lambda ()
+	       (if (not batch?)
+		   (display "- " out))
+	       (let ((form (read in)))
+		 (cond ((eof-object? form)
+			(newline out)
+			(go (lambda () 0)))
+		       ((and (pair? form) (eq? (car form) 'unquote))
+			(case (cadr form)
+			  ((load)
+			   (mini-load in)
+			   (go loop))
+			  ((go)
+			   (let ((form (read in)))
+			     (go (lambda ()
+				   (eval form (interaction-environment))))))
+			  (else (error "unknown command" (cadr form)))))
+		       (else
+			(call-with-values
+			    (lambda () (eval form (interaction-environment)))
+			  (lambda results
+			    (for-each (lambda (result)
+					(write result out)
+					(newline out))
+				      results)
+			    (go loop))))))))))))))
+
+(define (mini-load in)
+  (let ((c (peek-char in)))
+    (cond ((char=? c #\newline) (read-char in) #t)
+	  ((char-whitespace? c) (read-char in) (mini-load in))
+	  (else
+	   (let ((filename (read-string in char-whitespace?)))
+	     (load filename)
+	     (mini-load in))))))
+
+(define (read-string port delimiter?)
+  (let loop ((l '()) (n 0))
+    (let ((c (peek-char port)))
+      (cond ((or (eof-object? c)
+                 (delimiter? c))
+             (list->string (reverse l)))
+            (else
+             (loop (cons (read-char port) l) (+ n 1)))))))
diff --git a/scheme/debug/mini-eval.scm b/scheme/debug/mini-eval.scm
new file mode 100644
index 0000000..4513782
--- /dev/null
+++ b/scheme/debug/mini-eval.scm
@@ -0,0 +1,113 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Miniature evaluator.
+
+(define (eval form package)
+  (evil form package))
+
+(define (evil exp env)
+  (cond ((symbol? exp) (env exp))
+	((not (pair? exp)) exp)
+	((eq? (car exp) 'quote) (cadr exp))
+	((eq? (car exp) 'lambda)
+	 (lambda args
+	   (evil-begin (cddr exp) (bind (cadr exp) args env))))
+	((eq? (car exp) 'if)
+	 (evil (if (evil (cadr exp) env)
+		   (caddr exp)
+		   (cadddr exp))
+	       env))
+	((eq? (car exp) 'define)
+	 (let* ((pat (cadr exp))
+		(lhs (if (pair? pat) (car pat) pat))
+		(rhs (if (pair? pat)
+			 `(lambda ,(cdr pat) ,@(cddr exp))
+			 (caddr exp))))
+	   ((env '%%define%%) lhs (evil rhs env))))
+	(else
+	 (apply (evil (car exp) env)
+		(map (lambda (arg) (evil arg env)) (cdr exp))))))
+
+(define (evil-begin exp-list env)
+  (if (null? (cdr exp-list))
+      (evil (car exp-list) env)
+      (begin (evil (car exp-list) env)
+	     (evil-begin (cdr exp-list) env))))
+
+(define (bind names vals env)
+  (let ((alist (map cons names vals)))
+    (lambda (name)
+      (let ((probe (assq name alist)))
+	(if probe (cdr probe) (env name))))))
+
+; Initial package
+
+(define (initial-package name)
+  (let ((probe (assq name *initial-bindings*)))
+    (if probe (cdr probe) (error "unbound" name))))
+
+(define (define-initial name val)
+  (let ((probe (assq name *initial-bindings*)))
+    (if probe
+	(set-cdr! probe val)
+	(set! *initial-bindings*
+	      (cons (cons name val) *initial-bindings*)))))
+
+(define *initial-bindings*
+  (list (cons '%%define%% define-initial)))
+
+(define-syntax define-initial-stuff
+  (syntax-rules ()
+    ((define-initial-stuff ?name ...)
+     (for-each define-initial
+	       '(?name ...)
+	       (list ?name ...)))))
+
+(define-initial-stuff
+  cons car cdr + - * / < = > list map append reverse
+  make-vector vector-ref vector-set! vector-length
+  apply)
+
+
+; LOAD
+
+(define (load filename)
+  (load-into filename (interaction-environment)))
+
+(define (load-into filename env)
+  (call-with-input-file filename
+    (lambda (port)
+      (let loop ()
+	(let ((form (read port)))
+	  (cond ((eof-object? form))
+		(else
+		 (eval form env)
+		 (loop))))))))
+
+(define (eval-from-file forms env filename)
+  (for-each (lambda (form) (eval form env)) forms))
+(define (eval-scanned-forms forms env filename)
+  (for-each (lambda (form) (eval form env)) forms))
+
+
+; Interaction environment
+
+(define (set-interaction-environment! package)
+  (set! *interaction-environment* package))
+
+(define (interaction-environment)
+  *interaction-environment*)
+
+(define *interaction-environment* initial-package)
+
+(define (set-scheme-report-environment! n package)
+  (set! *scheme-report-environment* package))
+
+(define (scheme-report-environment n)
+  *scheme-report-environment*)
+
+(define (null-environment n)
+  *scheme-report-environment*)
+
+(define *scheme-report-environment* #f)
diff --git a/scheme/debug/mini-package.scm b/scheme/debug/mini-package.scm
new file mode 100644
index 0000000..1a4a2f3
--- /dev/null
+++ b/scheme/debug/mini-package.scm
@@ -0,0 +1,75 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Miniature package system.  This links mini-eval up to the output of
+; the package reifier.
+
+(define (package names locs get-location uid) ;Reified package
+  (lambda (name)
+    (let loop ((i (- (vector-length names) 1)))
+      (if (< i 0)
+	  (error "unbound" name)
+	  (if (eq? name (vector-ref names i))
+	      (contents (get-location (vector-ref locs i)))
+	      (loop (- i 1)))))))
+
+(define (make-simple-package opens foo1 foo2 name)
+  
+  (define bindings
+    (list (cons '%%define%%
+		(lambda (name val)
+		  (set! bindings (cons (cons name val) bindings))))))
+
+  (lambda (name)
+    (let ((probe (assq name bindings)))
+      (if probe
+	  (cdr probe)
+	  (let loop ((opens opens))
+	    (if (null? opens)
+		(error "unbound" name)
+		(if (memq name (structure-interface (car opens)))
+		    ((structure-package (car opens)) name)
+		    (loop (cdr opens)))))))))
+
+; Structures
+
+(define (make-structure package interface . name-option)
+  (cons package (vector->list interface)))
+
+(define structure-interface cdr)
+(define structure-package car)
+
+
+; Things used by reification forms
+
+(define (operator name type-exp)
+  `(operator ,name ,type-exp))
+
+(define (simple-interface names type) names)
+
+; Etc.
+
+(define (transform . rest) (cons 'transform rest))
+(define (usual-transform . rest)
+  (cons 'usual-transform rest))
+
+(define (transform-for-structure-ref . rest)
+  (cons 'transform-for-structure-ref rest))
+(define (inline-transform . rest)
+  (cons 'inline-transform rest))
+(define (primop . rest)
+  (cons 'primop rest))
+
+(define (package-define-static! package name op) 'lose)
+
+; --------------------
+; ???
+
+; (define (integrate-all-primitives! . rest) 'lose)
+
+;(define (package-lookup p name)
+;  ((p '%%lookup-operator%%) name))
+
+;(define (package-ensure-defined! p name)
+;  (package-define! p name (make-location 'defined name)))
+
diff --git a/scheme/debug/mini-start.scm b/scheme/debug/mini-start.scm
new file mode 100644
index 0000000..7a65cb2
--- /dev/null
+++ b/scheme/debug/mini-start.scm
@@ -0,0 +1,19 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Start up a system that has reified packages.
+; COMMAND-PROCESSOR might be either the miniature one or the real one.
+
+(define (start structs-thunk)
+  (usual-resumer
+   (lambda (arg)
+     (initialize-interaction-environment! (structs-thunk))
+     (command-processor #f arg))))
+
+(define (initialize-interaction-environment! structs)
+  (let ((scheme (cdr (assq 'scheme structs))))
+    (let ((tower (delay (cons eval (scheme-report-environment 5)))))
+      (set-interaction-environment!
+         (make-simple-package (map cdr structs) #t tower 'interaction))
+      (set-scheme-report-environment!
+         5
+	 (make-simple-package (list scheme) #t tower 'r5rs)))))
diff --git a/scheme/debug/mumble-packages.scm b/scheme/debug/mumble-packages.scm
new file mode 100644
index 0000000..dea9b0f
--- /dev/null
+++ b/scheme/debug/mumble-packages.scm
@@ -0,0 +1,73 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This is for version 0.28
+; We define these two because they aren't reified:
+;   scheme-level-0
+;   silly
+
+; We redefine these two so as not to compromise the security of the
+; built-in exception and interrupt systems:
+;   primitives
+;   signals
+
+
+; Suppose you have just done "make image" to build the scheme48 heap image.
+; Suppose that the linker produces an initial.image, but that when that
+; image is resumed you get the error
+;     exception handler is not a closure
+; This is not informative.  To find out what really happened, you have
+; two choices:
+;   (1) Run the image under the VM running in Scheme.
+;   (2) Run the image using the following handy dandy tool.
+; For choice (2), you would do something like the following:
+;
+;  ,translate =scheme48/ ./
+;  ,config ,load debug/mumble-packages.scm
+;  ,in link-config
+;  y
+;  ;; Cf. Makefile rule for initial.image
+;  ,load interfaces.scm packages.scm debug/fix-low.scm
+;  (flatload initial-structures)
+;  ,load initial.scm
+;  (define test (link-initial-system))
+
+; primitives-internal
+; ,open ##
+
+; Replacement for the structure defined in link-packages.scm
+(define-structure linker (export link-simple-system
+				 link-reified-system
+				 (struct-list :syntax))
+  (open scheme
+        packages		;make-simple-package
+        reification
+        ensures-loaded
+	)		; (enum interrupt keyboard)
+  (files linker))
+
+; Copied from link-packages.scm
+(define-structure loadc (export load-configuration
+				(structure-ref :syntax))
+  (open scheme
+	environments		; *structure-ref
+	fluids)
+  (files ((".." link) loadc)))
+
+; Replacement for the structure defined in link-packages.scm
+
+(define-structure link-config (export )  ;dummy structure...
+  (open scheme
+	linker
+	;; low-structures
+	;; start-debugging
+	defpackage
+	types
+	analysis
+	structure-refs    ;the real one
+	loadc		  ;defines structure-ref, but not the one we want
+	flatloading
+	ensures-loaded
+	interfaces)
+  (access built-in-structures)
+  (begin 0))
diff --git a/scheme/debug/mutation.scm b/scheme/debug/mutation.scm
new file mode 100644
index 0000000..22ffa48
--- /dev/null
+++ b/scheme/debug/mutation.scm
@@ -0,0 +1,130 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+
+; Package mutation tests
+
+"
+,translate =scheme48/ ./
+,open packages compiler built-in-structures handle condition
+,open interfaces table defpackage package-mutation
+"
+
+(define (try exp env . should-return-option)
+  (let ((val (ignore-errors (lambda () (eval exp env)))))
+    (if (if (null? should-return-option)
+	    (error? val)
+	    (not (if (eq? (car should-return-option) 'error)
+		     (error? val)
+		     (eq? val (car should-return-option)))))
+	(begin (write `(lost: ,exp => ,val))
+	       (newline)))))
+
+(define p1 (make-simple-package (list scheme) eval #f 'p1))
+
+(try 'a p1 'error)
+
+(try '(define a 'aa) p1)
+(try 'a p1 'aa)
+
+(try '(define (foo) b) p1)
+(try '(foo) p1 'error)
+
+(try '(define b 'bb) p1)
+(try 'b p1 'bb)
+(try '(foo) p1 'bb)
+
+
+(define s1-sig (make-simple-interface 's1-sig '(((a b c d e f) value))))
+(define s1 (make-structure p1 (lambda () s1-sig) 's1))
+
+(define p2 (make-simple-package (list s1 scheme) eval #f 'p2))
+
+(try 'b p2 'bb)
+(try 'c p2 'error)
+(try 'z p2 'error)
+
+(try '(define (bar) c) p2)
+(try '(bar) p2 'error)
+(try '(define c 'cc) p1)
+(try 'c p2 'cc)
+(try '(bar) p2 'cc)
+
+(try '(define (baz1) d) p1)
+(try '(define (baz2) d) p2)
+(try '(baz1) p1 'error)
+(try '(baz2) p2 'error)
+(try '(define d 'dd) p1)
+(try '(baz1) p1 'dd)
+(try '(baz2) p2 'dd)
+
+; Shadow
+(try '(define d 'shadowed) p2)
+(try '(baz1) p1 'dd)
+(try '(baz2) p2 'shadowed)
+
+; Shadow undefined
+(try '(define (moo1) f) p1)
+(try '(define (moo2) f) p2)
+(try '(define f 'ff) p2)
+(try '(moo1) p1 'error)
+(try '(moo2) p2 'ff)
+
+
+(try '(define (quux1) e) p1)
+(try '(define (quux2) e) p2)
+(try '(define (quux3 x) (set! e x)) p1)
+(try '(define (quux4 x) (set! e x)) p2)
+;
+(try '(quux1) p1 'error)
+(try '(quux2) p2 'error)
+(try '(quux3 'q3) p1 'error)
+(try '(quux4 'q4) p2 'error)
+;
+(try '(define e 'ee) p1)
+(try '(quux1) p1 'ee)
+(try '(quux2) p2 'ee)
+(try '(quux3 'q3) p1)
+(try '(quux1) p1 'q3)
+(try '(quux2) p2 'q3)
+(try '(quux4 'q4) p2 'error)
+;
+(try '(define e 'ee2) p2)
+(try '(quux1) p1 'q3)
+(try '(quux2) p2 'ee2)
+(try '(quux3 'qq3) p1)
+(try '(quux4 'qq4) p2)
+(try '(quux1) p1 'qq3)
+(try '(quux2) p2 'qq4)
+
+
+; (set-verify-later! really-verify-later!)
+
+(define-interface s3-sig (export a b x y z))
+
+(define s3
+  (make-structure p1 (lambda () s3-sig) 's3))
+
+(define p4 (make-simple-package (list s3 scheme) eval #f 'p4))
+
+(try '(define (fuu1) a) p4)
+(try '(define (fuu2) d) p4)
+(try '(fuu1) p4 'aa)
+(try '(fuu2) p4 'error)
+
+; Remove a, add d
+(define-interface s3-sig (export b d x y z))
+;(package-system-sentinel)
+
+(try 'a p4 'error)
+(try 'd p4 'dd)
+(try '(fuu2) p4 'dd)
+(try '(fuu1) p4 'error)    ; Foo.
+
+
+
+(define (table->alist t)
+  (let ((l '()))
+    (table-walk (lambda (key val) (set! l (cons (cons key val) l))) t)
+    l))
+
diff --git a/scheme/debug/profile.scm b/scheme/debug/profile.scm
new file mode 100644
index 0000000..f25adf9
--- /dev/null
+++ b/scheme/debug/profile.scm
@@ -0,0 +1,107 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; This was a fun hack, but I didn't get much useful information out of
+; it -- a profiler that only samples at points allowed by the VM's
+; interrupt mechanism doesn't tell you what you want to know.  The
+; only information available at that point is the continuation; what
+; we really want to know is where the PC has been.  In particular, the
+; only procedures that show up in the table at all are those that call
+; other procedures.    JAR 12/92
+
+'
+(define-structure profiler (export profile)
+  (open scheme-level-2 handle exception ;interrupts
+	architecture continuation signals condition template
+	table structure-refs debug-data sort
+	clock) ;schedule-interrupt
+  (files (misc profile)))
+
+(define (profile thunk frequency)
+  (let ((table (make-table template-uid))
+	(dt (round (/ (expt 10 6) frequency))))
+    (primitive-catch
+      (lambda (k0)
+	(let ((foo (continuation-template k0)))
+	  (with-handler
+	      (lambda (c punt)
+		(if (and (interrupt? c)
+			 (eq? (interrupt-type c) interrupt/alarm))
+		    (primitive-catch
+		      (lambda (k)
+			(record-profile-information! k foo table)
+			(schedule-interrupt dt)))
+		    (punt)))
+	    (lambda ()
+	      (dynamic-wind (lambda () (schedule-interrupt dt -6))
+			    thunk
+			    (lambda () (schedule-interrupt 0 1))))))))
+    table))
+
+(define (record-profile-information! k k0-template table)
+  (let ((k1 (continuation-cont (continuation-cont k))))
+    (let ((z (get-counts table k1)))
+      (set-car! z (+ (car z) 1))
+      (set-cdr! z (+ (cdr z) 1)))
+    (do ((k (continuation-parent k1) (continuation-parent k)))
+	((or (not (continuation? k))
+	     (eq? (continuation-template k) k0-template)))
+      (let ((z (get-counts table k)))
+	(set-cdr! z (+ (cdr z) 1))))))
+
+(define (get-counts table k)
+  (let ((info (template-info (continuation-template k))))
+    (or (table-ref table info)
+	(let ((z (cons 0 0)))
+	  (table-set! table info z)
+	  z))))
+
+(define (template-uid info)
+  (cond ((integer? info)
+	 info)
+	((debug-data? info)
+	 (debug-data-uid info))
+	(else 0)))  ;??
+
+(define interrupt-type cadr)
+(define interrupt/alarm (enum interrupt alarm))
+
+(define (dump t)
+  (let ((l '()))
+    (table-walk (lambda (key count)
+		  (let ((dd (if (integer? key)
+				(table-ref debug-data-table key)
+				key)))
+		    (set! l (cons (cons count
+					(if (debug-data? dd)
+					    (debug-data-names dd)
+					    `(? ,key)))
+				  l))))
+		t)
+    (do ((l (sort-list l more-interesting?)
+	    (cdr l))
+	 (i 0 (+ i 1)))
+	((or (null? l) (> i *prefix*)))
+      (let* ((counts+names (car l))
+	     (leaf-count (caar counts+names))
+	     (total-count (cdar counts+names))
+	     (names (cdr counts+names)))
+	(display (pad-left total-count 6)) (display #\space)
+	(display (pad-left leaf-count 6)) (display #\space)
+	(write names)
+	(newline)))))
+
+(define (more-interesting? x y)
+  (let ((c1 (cdar x))
+	(c2 (cdar y)))
+    (or (> c1 c2)
+	(and (= c1 c2)
+	     (> (caar x) (caar y))))))
+
+
+(define *prefix* 60)
+(define (pad-left s n)
+  (let ((s (cond ((number? s) (number->string s))
+		 ((symbol? s) (symbol->string s))
+		 (else s))))
+    (string-append (make-string (- n (string-length s)) #\space)
+		   s)))
diff --git a/scheme/debug/r5-system.scm b/scheme/debug/r5-system.scm
new file mode 100644
index 0000000..1180133
--- /dev/null
+++ b/scheme/debug/r5-system.scm
@@ -0,0 +1,22 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Link script.
+
+(define (link-revised^5-system)
+  (let ((structures-to-open (struct-list scheme)))
+    (link-reified-system structures-to-open
+			 'revised^5
+			 `(start ',(map car structures-to-open))
+			 initial-system
+			 for-reification
+			 ;; Extra stuff (from more-packages.scm)
+			 disclosers
+			 package-mutation shadowing
+			 bignums ratnums floatnums
+			 )))
+
+(define scheme (make-scheme environments evaluation))
+
+(define initial-system
+  (make-initial-system scheme (make-mini-command scheme)))
diff --git a/scheme/debug/read-image.scm b/scheme/debug/read-image.scm
new file mode 100644
index 0000000..9e2bb19
--- /dev/null
+++ b/scheme/debug/read-image.scm
@@ -0,0 +1,223 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+
+;(define-syntax assert
+;  (lambda ignore
+;    ''assert))
+
+(define debugging? #t)
+
+; ,bench
+; ,load rts/defenum.scm
+; ,for-syntax ,load my-vm/for-syntax.scm
+; ,load my-vm/s48-prescheme.scm my-vm/util.scm my-vm/memory.scm
+; ,load my-vm/arch.scm my-vm/data.scm my-vm/struct.scm
+; ,load link/s48-features.scm link/read-image.scm
+; ,load-into extended-numbers misc/bigbit.scm
+
+(define (resume filename arg)
+  (call-startup-procedure (extract (read-image filename)) arg))
+
+(define (call-startup-procedure proc arg)
+  (proc arg (current-input-port) (current-output-port)))
+
+(define level 14)
+
+(define (read-image filename)
+  (call-with-input-file filename
+    (lambda (port)
+      (read-page port) ; read past any user cruft at the beginning of the file
+      (let* ((old-level          (read-number port))
+             (old-bytes-per-cell (read-number port))
+             (old-begin (cells->a-units (read-number port)))
+             (old-hp    (cells->a-units (read-number port)))
+             (startup-proc       (read-number port)))
+        (read-page port)
+        (if (not (= old-level level))
+            (error "format of image is incompatible with this version of system"
+                   old-level level))
+        (if (not (= old-bytes-per-cell bytes-per-cell))
+            (error "incompatible bytes-per-cell"
+                   old-bytes-per-cell bytes-per-cell))
+
+	;; ***CHANGED***
+	(create-memory (a-units->cells (- (addr1+ old-hp) old-begin))
+		       quiescent)
+	(set! *hp* 0)
+
+        (let* ((delta (- *hp* old-begin))
+               (new-hp (+ old-hp delta)))
+	  (let ((reverse? (check-image-byte-order port)))
+	    (read-block port *memory* *hp* (- old-hp old-begin))
+	    (if reverse?
+		(reverse-byte-order new-hp))
+	    (if (= delta 0)
+		(set! *hp* new-hp)
+		(relocate-image delta new-hp))
+	    (set! *extracted* (make-vector (a-units->cells *memory-end*) #f))
+	    (adjust startup-proc delta)))))))
+
+(define (check-image-byte-order port)
+  (read-block port *memory* *hp* (cells->a-units 1))
+  (cond ((= (fetch *hp*) 1)
+	 #f)
+	(else
+	 (reverse-descriptor-byte-order! *hp*)
+	 (if (= (fetch *hp*) 1)
+	     #t
+	     (begin (error "unable to correct byte order" (fetch *hp*))
+		    #f)))))
+
+(define *hp* 0)
+
+(define *extracted* #f)
+
+(define (extract obj)
+  (cond ((vm-fixnum? obj) (extract-vm-fixnum obj))
+	((stob? obj)
+	 (let ((index (a-units->cells (address-after-header obj))))
+	   (or (vector-ref *extracted* index)
+	       (extract-stored-object obj
+				      (lambda (new)
+					(vector-set! *extracted* index new)
+					new)))))
+	((vm-char? obj) (extract-char obj))
+	((vm-eq? obj null) '())
+	((vm-eq? obj false) #f)
+	((vm-eq? obj true) #t)
+	((vm-eq? obj vm-unspecific) (if #f 0))
+	((vm-eq? obj unbound-marker) '<unbound>)
+	((vm-eq? obj unassigned-marker) '<unassigned>)
+	(else (error "random descriptor" obj))))
+
+(define (extract-stored-object old store-new!)
+  ((vector-ref stored-object-extractors (header-type (stob-header old)))
+   old store-new!))
+
+(define stored-object-extractors
+  (make-vector stob-count (lambda rest (apply error "no extractor" rest))))
+
+(define (define-extractor which proc)
+  (vector-set! stored-object-extractors which proc))
+
+(define-extractor stob/pair
+  (lambda (old store-new!)
+    (let ((new (cons #f #f)))
+      (store-new! new)
+      (set-car! new (extract (vm-car old)))
+      (set-cdr! new (extract (vm-cdr old)))
+      new)))
+
+(define-extractor stob/vm-closure
+  (lambda (old store-new!)
+    (store-new! (make-closure (extract (vm-closure-template old))
+			      (extract (vm-closure-env old))))))
+
+(define-extractor stob/symbol
+  (lambda (obj store-new!)
+    (store-new! (string->symbol (extract (vm-symbol->string obj))))))
+
+(define-extractor stob/vm-location
+  (lambda (obj store-new!)
+    (let ((new (store-new! (make-undefined-location
+			        (+ 10000
+				   (extract (vm-location-id obj))))))
+	  (val (vm-contents obj)))
+      (if (not (vm-eq? val unbound-marker))
+	  (begin (set-location-defined?! new #t)
+		 (if (not (vm-eq? val unassigned-marker))
+		     (set-contents! new (extract val)))))
+      new)))
+
+(define-extractor stob/string
+  (lambda (obj store-new!)
+    (store-new! (extract-string obj))))
+
+(define-extractor stob/vm-code-vector
+  (lambda (obj store-new!)
+    (store-new! (extract-code-vector obj))))
+
+(define-extractor stob/vector
+  (lambda (obj store-new!)
+    (let* ((z (vm-vector-length obj))
+	   (v (make-vector z)))
+      (store-new! v)
+      (do ((i 0 (+ i 1)))
+	  ((= i z) v)
+	(vector-set! v i (extract (vm-vector-ref obj i)))))))
+
+;(define-extractor stob/record
+;  (lambda (obj store-new!)
+;    (let* ((z (vm-record-length obj))
+;           (v (make-record z)))
+;      (store-new! v)
+;      (do ((i 0 (+ i 1)))
+;          ((= i z) v)
+;        (record-set! v i (extract (vm-record-ref obj i)))))))
+
+(define-extractor stob/port
+  (lambda (obj store-new!)
+    (store-new!
+     (case (extract-vm-fixnum (port-index obj))
+       ((0) (current-input-port))
+       ((1) (current-output-port))
+       (else (error "unextractable port" obj))))))
+
+
+
+(define (extract-code-vector x)
+  (let ((z (vm-code-vector-length x)))
+    (let ((v (make-code-vector z 0)))
+      (do ((i 0 (+ i 1)))
+          ((>= i z) v)
+        (code-vector-set! v i (vm-code-vector-ref x i))))))
+
+
+
+; Various things copied from vm/gc.scm
+
+(define (store-next! descriptor)
+  (store! *hp* descriptor)
+  (set! *hp* (addr1+ *hp*)))
+
+(define (reverse-descriptor-byte-order! addr)
+  (let ((x (fetch-byte addr)))
+    (store-byte! addr (fetch-byte (addr+ addr 3)))
+    (store-byte! (addr+ addr 3) x))
+  (let ((x (fetch-byte (addr+ addr 1))))
+    (store-byte! (addr+ addr 1) (fetch-byte (addr+ addr 2)))
+    (store-byte! (addr+ addr 2) x)))
+
+(define (reverse-byte-order end)
+  (write-string "Correcting byte order of resumed image."
+		 (current-output-port))
+  (newline (current-output-port))
+  (let loop ((ptr *hp*))
+    (reverse-descriptor-byte-order! ptr)
+    (let ((value (fetch ptr)))
+      (if (addr< ptr end)
+	  (loop (if (b-vector-header? value)
+		    (addr+ (addr1+ ptr) (header-a-units value))
+		    (addr1+ ptr)))))))
+
+(define (adjust descriptor delta)
+  (if (stob? descriptor)
+      (make-stob-descriptor (addr+ (address-after-header descriptor) delta))
+      descriptor))
+
+(define (relocate-image delta new-hp)
+  (let loop ()
+    (cond ((addr< *hp* new-hp)
+	   (let ((d (adjust (fetch *hp*) delta)))
+	     (store-next! d)
+	     (cond ;;((eq? d the-primitive-header)
+	       ;; Read symbolic label name.
+	       ;;(store-next!
+	       ;;  (label->fixnum (name->label (read port)))))
+	       ((b-vector-header? d)
+		(set! *hp* (addr+ *hp*
+				  (cells->bytes
+				   (bytes->cells
+				    (header-length-in-bytes d)))))))
+	     (loop))))))
diff --git a/scheme/debug/run.scm b/scheme/debug/run.scm
new file mode 100644
index 0000000..c761356
--- /dev/null
+++ b/scheme/debug/run.scm
@@ -0,0 +1,281 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; These are the four entry points (cf. rts/eval.scm):
+
+; EVAL
+
+(define (eval form package)
+  (compile-and-run (list form) package #f))
+
+; LOAD-INTO - load file into package.
+
+(define (load-into filename package)
+  (compile-and-run (read-forms filename package)
+		   package
+		   filename))
+
+; Evaluate forms as if they came from the given file.
+
+(define (eval-from-file forms package filename)
+  (if filename
+      ((fluid $note-file-package)
+        filename package))
+  (compile-and-run forms package filename))
+
+; LOAD
+
+(define (load filename . package-option)
+  (let ((package (if (null? package-option)
+		     (interaction-environment)
+		     (car package-option))))
+    (load-into filename package)))
+
+;----------------
+
+(define (compile-and-run forms package maybe-filename)
+  (let* ((env (if maybe-filename
+		  (bind-source-file-name maybe-filename
+					 (package->environment package))
+		  (package->environment package)))
+	 (nodes (map (lambda (form)
+		       (expand-scanned-form form env))
+		     (scan-forms forms env))))
+    (if (not (null? nodes))
+	(run-nodes nodes env))))
+
+(define (run-nodes nodes env)
+  (do ((nodes nodes (cdr nodes)))
+      ((null? (cdr nodes))
+       (run-node (car nodes) env))
+    (run-node (car nodes) env)))
+
+(define (run-node node env)
+  (cond ((define-node? node)
+	 (let* ((form (node-form node))
+		(loc (binding-place (lookup env (cadr form))))
+		(value (run (caddr form) env)))
+	   (set-location-defined?! loc #t)
+	   (set-contents! loc value)))
+	((not (define-syntax-node? node))
+	 (run node env))))
+
+; Main dispatch for a single expression.
+
+(define (run node env)
+  ((operator-table-ref interpreters (node-operator-id node))
+     node
+     env))
+
+(define interpreters
+  (make-operator-table (lambda (node env)
+			 (run-call (node-form node) env))))
+
+(define (define-interpreter name type proc)
+  (operator-define! interpreters name type proc))
+
+(define-interpreter 'name #f
+  (lambda (node env)
+    (let ((binding (name-node-binding node env)))
+      (cond ((binding? binding)
+	     (if (and (compatible-types? (binding-type binding) value-type)
+		      (location? (binding-place binding)))
+		 (let ((loc (binding-place binding)))
+		   (if (location-defined? loc)
+		       (contents loc)
+		       (error "uninitialized variable" (schemify node env))))
+		 (error "invalid variable reference" (schemify node env))))
+	    ((unbound? binding)
+	     (error "unbound variable" (schemify node env)))
+	    (else
+	     (error "peculiar binding" node binding))))))
+
+(define (name-node-binding node env)
+  (or (node-ref node 'binding)
+      (lookup env (node-form node))))
+
+(define-interpreter 'literal #f
+  (lambda (node env)
+    (node-form node)))
+
+(define-interpreter 'call #f
+  (lambda (node env)
+    (run-call (node-form node) env)))
+
+(define (run-call exp env)
+  (let ((proc (run (car exp) env)))	;Doing this first aids debugging
+    (apply proc
+	   (map (lambda (arg-exp)
+		  (run arg-exp env))
+		(cdr exp)))))
+
+(define-interpreter 'quote syntax-type
+  (lambda (node env)
+    (cadr (node-form node))))
+
+(define-interpreter 'lambda syntax-type
+  (lambda (node env)
+    (let ((exp (node-form node)))
+      (make-interpreted-closure (cadr exp) (cddr exp) env))))
+
+(define (make-interpreted-closure formals body env)
+  (lambda args
+    (run-body body (bind-vars formals args env))))
+
+(define (run-body body env)
+  (scan-body
+      body
+      env
+      (lambda (defs exps)
+	(if (null? defs)
+	    (run-begin exps env)
+	    (run-letrec (map (lambda (def) (cdr (node-form def))) defs)
+			exps
+			env)))))
+
+
+(define-interpreter 'begin syntax-type
+  (lambda (node env)
+    (let ((exp (node-form node)))
+      (run-begin (cdr exp) env))))
+
+(define (run-begin exp-list env)
+  (if (null? exp-list)
+      (syntax-error "null begin")
+      (let loop ((exp-list exp-list))
+	(if (null? (cdr exp-list))
+	    (run (car exp-list) env)
+	    (begin (run (car exp-list) env)
+		   (loop (cdr exp-list)))))))
+
+(define-interpreter 'set! syntax-type
+  (lambda (node env)
+    (let* ((exp (node-form node))
+	   (probe (name-node-binding (cadr exp) env)))
+      (cond ((and (binding? probe)
+		  (location? (binding-place probe)))
+	     (if (and (location-defined? (binding-place probe))
+		      (variable-type? (binding-type probe)))
+		 (set-contents! (binding-place probe)
+				(run (caddr exp) env))
+		 (error "invalid assignment" (schemify node env))))
+	    ((unbound? probe) (error "unbound variable" exp))
+	    (else (error "peculiar assignment" exp))))))
+
+(define-interpreter 'if syntax-type
+  (lambda (node env)
+    (let ((exp (node-form node)))
+      (if (null? (cdddr exp))
+	  (if (run (cadr exp) env)
+	      (run (caddr exp) env))	;hack
+	  (if (run (cadr exp) env)
+	      (run (caddr exp) env)
+	      (run (cadddr exp) env))))))
+
+; (reverse specs) in order to try to catch unportabilities
+
+(define-interpreter 'letrec syntax-type
+  (lambda (node env)
+    (let ((exp (node-form node)))
+      (run-letrec (cadr exp) (cddr exp) env))))
+
+(define (run-letrec specs body env)
+  (let* ((bindings (map (lambda (spec)
+			  (make-binding usual-variable-type
+					(make-undefined-location (car spec))
+					#f))
+			specs))
+	 (env (bind (map car specs)
+		    bindings
+		    env)))
+    (for-each (lambda (binding val)
+		(let ((loc (binding-place binding)))
+		  (set-location-defined?! loc #t)
+		  (set-contents! loc val)))
+	      bindings
+	      (map (lambda (spec) (run (cadr spec) env)) specs))
+    (run-body body env)))
+
+
+(let ((bad (lambda (node env)
+	     (error "not valid in expression context" (node-form node)))))
+  (define-interpreter 'define syntax-type bad)
+  (define-interpreter 'define-syntax syntax-type bad))
+
+
+; Primitive procedures
+
+(define-interpreter 'primitive-procedure syntax-type
+  (lambda (node env)
+    (let ((name (cadr (node-form node))))
+      (or (table-ref primitive-procedures name)
+	  (lambda args
+	    (error "unimplemented primitive procedure" name))))))
+
+(define primitive-procedures (make-table))
+
+(define (define-a-primitive name proc)
+  (table-set! primitive-procedures name proc)
+  (define-interpreter name any-procedure-type
+    (lambda (node env)
+      (apply proc (map (lambda (arg) (run arg env))
+		       (cdr (node-form node)))))))
+
+(define-a-primitive 'unspecific
+  (lambda () (if #f #f)))		;For COND
+
+(define-syntax define-some-primitives
+  (syntax-rules ()
+    ((define-some-primitives name ...)
+     (begin (define-a-primitive 'name name) ...))))
+
+(define-some-primitives
+  + - * quotient remainder = <
+  eq? car cdr cons
+  pair?
+  vector? vector-ref string? string-ref
+  symbol?
+  char<? char=?)
+
+
+; --------------------
+; Environments
+
+(define (bind-var name arg env)
+  (let ((loc (make-undefined-location name)))
+    (set-location-defined?! loc #t)
+    (set-contents! loc arg)
+    (bind1 name (make-binding usual-variable-type loc #f) env)))
+
+(define (bind-vars names args env)
+  (cond ((null? names)
+	 (if (null? args)
+	     env
+	     (error "too many arguments" args)))
+	((not (pair? names))
+	 (bind-var names args env))
+	((null? args)
+	 (error "too few arguments" names))
+	(else
+	 (bind-var (car names) (car args)
+		   (bind-vars (cdr names) (cdr args) env)))))
+
+
+; LOAD
+
+(define (load filename . package-option)
+  (load-into filename (if (null? package-option)
+			  (interaction-environment)
+			  (car package-option))))
+
+(define (load-into filename package)
+  (eval-nodes (read-forms filename package)
+	      (package->environment package)
+	      filename))
+
+
+(define (eval-from-file forms package file)	;Scheme 48 internal thing
+  (eval-forms forms package file))
+
+
+; (scan-structures (list s) (lambda (p) #t) (lambda (stuff) #f))
diff --git a/scheme/debug/small-packages.scm b/scheme/debug/small-packages.scm
new file mode 100644
index 0000000..76a884a
--- /dev/null
+++ b/scheme/debug/small-packages.scm
@@ -0,0 +1,8 @@
+; no copyright
+
+; (link-simple-system '(debug small) 'start tiny-system)
+
+(define-structure small-system (export start)
+  (define-all-operators)
+  (usual-transforms and cond do let let* or)
+  (files (rts defenum) (rts arch) (debug small)))
diff --git a/scheme/debug/small.scm b/scheme/debug/small.scm
new file mode 100644
index 0000000..96eda0c
--- /dev/null
+++ b/scheme/debug/small.scm
@@ -0,0 +1,153 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Minimal full-I/O test system
+
+(define (start arg in-channel out-channel error-channel)
+  (set! *error-channel* error-channel)
+  (set-exception-handlers! exception-handlers)
+  (let* ((ch (open-channel "small-test.image"
+			   (enum open-channel-option input-file)))
+	 (out (output-channel->port out-channel))
+	 (in (input-channel->port in-channel)))
+    (write-string "Hello " out)
+    (collect)
+    (if (< 0 (vector-length arg))
+	(write-block (vector-ref arg 0)
+		     0
+		     (string-length (vector-ref arg 0))
+		     out))
+    (newline out)
+    (force-output out)
+    (let ((b (make-string 12 #\space)))
+      (channel-read b 0 12 ch)
+      (close-channel ch)
+      (write-string b out)
+      (newline out)
+      (force-output out))
+    (write-string "Eight chars> " out)
+    (force-output out)
+    (do ((i 0 (+ i 1)))
+	((= i 8))
+      (write-char (peek-char in) out)
+      (read-char in))
+    (newline out)
+    (force-output out)
+    (write-image "small-test.image" start "A small image")
+    0))
+
+(define buffer-size 4)  ; for testing
+
+(define (output-channel->port channel)
+  (make-port #f
+	     (bitwise-ior (arithmetic-shift 1 (enum port-status-options
+						    output))
+			  (arithmetic-shift 1 (enum port-status-options
+						    open-for-output)))
+	     channel
+	     #f #f #f ; input stuff
+	     (make-code-vector buffer-size 0)
+	     0))
+
+(define (input-channel->port channel)
+  (make-port #f
+	     (bitwise-ior (arithmetic-shift 1 (enum port-status-options
+						    input))
+			  (arithmetic-shift 1 (enum port-status-options
+						    open-for-input)))
+	     channel
+	     (make-code-vector buffer-size 0)
+	     0
+	     0
+	     #f #f))  ; ouput stuff
+
+(define *error-channel* #f)
+
+(define (error string . stuff)
+  (channel-write-string string *error-channel*)
+  (channel-newline *error-channel*)
+  (exit -1))
+
+(define (message string)
+  (channel-write-string string *error-channel*)
+  (channel-newline *error-channel*))
+
+(define (channel-write-string string channel)
+  (channel-write string
+		 0
+		 (string-length string)
+		 channel))
+
+(define (channel-newline channel)
+  (channel-write-string "
+" channel))
+
+(define (define-exception-handler opcode proc)
+  (vector-set! exception-handlers opcode proc))
+
+(define exception-handlers
+  (make-vector op-count #f))
+
+(define-exception-handler (enum op write-char)
+  (lambda (opcode reason char port)
+    (cond ((= reason (enum exception buffer-full/empty))
+	   (force-output port)
+	   (message "[overflow]")
+	   (write-char char port))
+	  (else
+	   (apply signal-exception opcode reason args)))))
+
+(define-exception-handler (enum op read-char)
+  (lambda (opcode reason port)
+    (cond ((= reason (enum exception buffer-full/empty))
+	   (fill-buffer port)
+	   (message "[underflow]")
+	   (read-char port))
+	  (else
+	   (apply signal-exception opcode reason args)))))
+
+(define-exception-handler (enum op peek-char)
+  (lambda (opcode reason port)
+    (cond ((= reason (enum exception buffer-full/empty))
+	   (fill-buffer port)
+	   (message "[underflow]")
+	   (peek-char port))
+	  (else
+	   (apply signal-exception opcode reason args)))))
+
+(define-exception-handler (enum op write-block)
+  (lambda (opcode reason thing start count port)
+    (cond ((= reason (enum exception buffer-full/empty))
+	   (force-output port)
+	   (write-buffer thing start count (port-data port)))
+	  (else
+	   (apply signal-exception opcode reason args)))))
+
+(define (force-output port)
+  (write-buffer (port-out-buffer port) 0 (port-out-index port) (port-data port))
+  (set-port-out-index! port 0))
+
+(define (write-buffer buffer start count channel)
+  (let loop ((start start) (count count))
+    (let ((sent (channel-write buffer start count channel)))
+      (if (< sent count)
+	  (loop (+ start sent) (- count sent))))))
+
+(define (fill-buffer port)
+  (let ((got (channel-read (port-in-buffer port)
+			   0
+			   (code-vector-length (port-in-buffer port))
+			   (port-data port))))
+    (cond ((= got 0)
+	   (fill-buffer port))
+	  (else
+	   (set-port-in-index! port 0)
+	   (set-port-in-limit! port got)))))
+
+(define (write-string string port)
+  (let ((l (string-length string)))
+    (do ((i 0 (+ i 1)))
+	((= i l))
+      (write-char (string-ref string i) port))))
+
+(define (newline port)
+  (write-char #\newline port))
diff --git a/scheme/debug/spatial-hack.scm b/scheme/debug/spatial-hack.scm
new file mode 100644
index 0000000..d0395c2
--- /dev/null
+++ b/scheme/debug/spatial-hack.scm
@@ -0,0 +1,63 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; load into initial image
+
+(init-defpackage! eval
+		  (lambda ()
+		    (delay (make-simple-package (list scheme-level-1)
+						#t (delay #f) 'for-syntax))))
+
+(define-structures ((assembler (export (lap syntax))))
+  (open scheme-level-2 compiler architecture
+	signals				;error
+	enumerated			;name->enumerand
+	code-vectors
+	locations)			;location?
+  (specials lap)
+  (files (env assem)))
+
+(ensure-loaded assembler)
+
+(define-structures ((spatial (export space init-space)))
+   (open scheme-level-2 architecture primitives packages)
+   (files (debug space)))
+
+(ensure-loaded spatial)
+
+((*structure-ref spatial 'init-space) eval assembler)
+
+(define-interface define-record-types-interface
+  (export (define-record-type syntax)
+	  define-record-discloser))
+(define-structures ((define-record-types define-record-types-interface))
+  (open scheme-level-1 record)
+  (files (rts jar-defrecord)))
+(define-interface queue-interface
+  (export make-queue enqueue! dequeue! queue-empty?
+	  queue? queue->list queue-length delete-from-queue!))
+(define-structures ((queues queue-interface))
+  (open scheme-level-1 define-record-types signals)
+  (files (big queue))
+  (optimize auto-integrate))
+(define-structure traverse
+    (export traverse-depth-first traverse-breadth-first trail
+	    set-leaf-predicate! usual-leaf-predicate)
+  (open scheme-level-2
+	primitives			; ?
+	queues table
+	bitwise locations closures code-vectors
+	features			; string-hash
+	low-level)			; flush-the-symbol-table!
+  (files (env traverse)))
+
+(ensure-loaded traverse)
+
+(define foo
+  (make-simple-package (list scheme-level-2
+			     spatial traverse vm-exposure)
+		       eval (delay #f) 'foo))
+
+; (define command-processor (*structure-ref command 'command-processor))
+
+; (set-interaction-environment! foo)
diff --git a/scheme/debug/test-generic.scm b/scheme/debug/test-generic.scm
new file mode 100644
index 0000000..31c138b
--- /dev/null
+++ b/scheme/debug/test-generic.scm
@@ -0,0 +1,34 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+(define g-methods (make-method-table 'g))
+
+(define g (make-generic g-methods))
+
+(define foo-family (make-family 'foo 1))
+
+(define-method g-methods foo-family
+  (lambda (x)
+    (if (even? x)
+	'win
+	(fail))))
+
+(define bar-family (make-family 'bar 2))  ;More specific
+
+(define-method g-methods bar-family
+  (lambda (x)
+    (case x
+      ((1 3 5) 'ok)
+      (else (fail)))))
+
+(define-method g-methods (make-family 'baz 2)  ;Same priority as bar-family
+  (lambda (x)
+    (case x
+      ((3) 'great)
+      (else (fail)))))
+
+; (g 0) => 'win
+; (g 1) => 'ok
+; (g 3) => 'great
+; (g 9) => error
+
diff --git a/scheme/debug/test-methods.scm b/scheme/debug/test-methods.scm
new file mode 100644
index 0000000..10c4c06
--- /dev/null
+++ b/scheme/debug/test-methods.scm
@@ -0,0 +1,37 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+(define-generic g &g)
+
+(define-method &g ((x :number)) 'win)
+
+(define-method &g ((n :integer))
+  (if (= n 13)
+      (next-method)
+      'ok))
+
+(define-method &g ((s :symbol))
+  (if (= s 13)
+      (next-method)
+      'ok))
+
+; (g 1/2) => 'win
+; (g 10) => 'ok
+; (g 13) => 'win
+
+
+(define-generic elt &elt)
+
+(define-method &elt ((x :vector) y)
+  (vector-ref x y))
+
+(define-method &elt ((x :string) y)
+  (string-ref x y))
+
+(define-method &elt ((x :list) y)
+  (list-ref x y))
+
+; Generic length
+
+; (define-generic-function glength ((s :sequence)))
+
diff --git a/scheme/debug/test.scm b/scheme/debug/test.scm
new file mode 100644
index 0000000..6d0cde3
--- /dev/null
+++ b/scheme/debug/test.scm
@@ -0,0 +1,34 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; ,config ,load debug/test.scm
+
+(define-structure testing (export (test :syntax) lost?)
+  (open scheme signals handle conditions)
+  (begin
+
+(define *lost?* #f)
+(define (lost?) *lost?*)
+
+(define (run-test string compare want thunk)
+  (let ((result
+	 (call-with-current-continuation
+	   (lambda (k)
+	     (with-handler (lambda (condition punt)
+			     (if (error? condition)
+				 (k condition)
+				 (punt)))
+	       thunk)))))
+    (if (not (compare want result))
+	(begin (display "Test ") (write string) (display " failed.") (newline)
+	       (display "Wanted ") (write want)
+	       (display ", but got ") (write result) (display ".")
+	       (newline)
+	       (set! *lost?* #t)))))
+
+(define-syntax test
+  (syntax-rules ()
+    ((test ?string ?compare ?want ?exp)
+     (run-test ?string ?compare ?want (lambda () ?exp)))))
+
+))
diff --git a/scheme/debug/thread-socket.scm b/scheme/debug/thread-socket.scm
new file mode 100644
index 0000000..576f6e5
--- /dev/null
+++ b/scheme/debug/thread-socket.scm
@@ -0,0 +1,60 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Code to check the interaction between threads and sockets.
+
+(define (run-server)
+  (with-multitasking server))
+
+(define (server)
+  (call-with-values socket-server
+    (lambda (port-number accept)
+      (display "Port number is ") (write port-number) (newline)
+      (let loop ()
+	(call-with-values accept
+	  (lambda (i-port o-port)
+	    (spawn (service i-port o-port))
+	    (loop)))))))
+
+(define (service i-port o-port)
+  (lambda ()
+    (let loop ((total 0))
+      (let ((next (read i-port)))
+	(cond ((eof-object? next)
+	       (close-input-port i-port)
+	       (close-output-port o-port))
+	      (else
+	       (let ((total (+ total next)))
+		 (write total o-port)
+		 (newline o-port)
+		 (loop total))))))))
+
+(define (run-users machine port-number . data)
+  (with-multitasking
+   (lambda ()
+     (do ((i 0 (+ i 1))
+	  (d data (cdr d)))
+	 ((null? d))
+       (let ((l (car d)))
+	 (spawn (lambda ()
+		  (user (make-name i) (car l) (cadr l) machine port-number))))))))
+
+(define (make-name i)
+  (list->string (list (string-ref "ABCDEFGHIJKLMNOPQRSTUVWXYZ" i))))
+
+(define (user id count delay machine port-number)
+  (call-with-values
+   (lambda ()
+     (socket-client machine port-number))
+   (lambda (i-port o-port)
+     (let loop ((count count))
+       (cond ((= 0 count)
+	      (close-input-port i-port)
+	      (close-output-port o-port))
+	     (else
+	      (write 1 o-port)
+	      (newline o-port)
+	      (for-each display (list id " got " (read i-port)))
+	      (newline)
+	      (sleep delay)
+	      (loop (- count 1))))))))
diff --git a/scheme/debug/tiny-packages.scm b/scheme/debug/tiny-packages.scm
new file mode 100644
index 0000000..69fe8c1
--- /dev/null
+++ b/scheme/debug/tiny-packages.scm
@@ -0,0 +1,7 @@
+; no copyright
+
+; (link-simple-system '(debug tiny) 'start tiny-system)
+
+(define-structure tiny-system (export start)
+  (define-all-operators)
+  (files tiny))
diff --git a/scheme/debug/tiny.scm b/scheme/debug/tiny.scm
new file mode 100644
index 0000000..2640dcc
--- /dev/null
+++ b/scheme/debug/tiny.scm
@@ -0,0 +1,66 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Tiny image and simple I/O test system
+
+; This prints `Hello' and the first command argument, if any, then reads
+; a line from standard input and prints it to standard output.
+
+(define (start arg in out error-out resumer-records)
+  (write-string "Hello " out)
+  (if (vector? arg)
+      (if (< 0 (vector-length arg))
+	  (write-string (vector-ref arg 0) out)))
+  (collect)
+  (collect)
+  (newline out)
+  (write-string (read-string in) out)
+  (newline out)
+  0)
+
+(define first? #t)
+
+(define (write-string string . channel-option)  ; test n-ary procedures
+  (channel-maybe-write string
+		       0
+		       (string-length string)
+		       (car channel-option)))
+
+(define (newline channel)
+  (write-string "
+" channel))
+
+(define (read-string in)
+  ((lambda (buffer)
+     (letrec ((loop (lambda (have)
+		      ((lambda (got)
+			 (if (eq? got (eof-object))
+			     "eof"
+			     ((lambda (len)
+				(if len
+				    ((lambda (string)
+				       (copy-string! buffer string len)
+				       string)
+				     (make-string len #\space))
+				    (loop (+ have got))))
+			      (has-newline buffer have got))))
+		       (channel-maybe-read buffer have (- 80 have) #f in)))))
+       (loop 0)))
+   (make-string 80 #\space)))
+
+(define (has-newline string start count)
+  (letrec ((loop (lambda (i)
+		   (if (= i count)
+		       #f
+		       (if (char=? #\newline
+				   (string-ref string (+ start i)))
+			   (+ start i)
+			   (loop (+ i 1)))))))
+    (loop 0)))
+
+(define (copy-string! from to count)
+  (letrec ((loop (lambda (i)
+		   (if (< i count)
+		       (begin
+			 (string-set! to i (string-ref from i))
+			 (loop (+ i 1)))))))
+    (loop 0)))
diff --git a/scheme/debug/vector-space.scm b/scheme/debug/vector-space.scm
new file mode 100644
index 0000000..c6c5756
--- /dev/null
+++ b/scheme/debug/vector-space.scm
@@ -0,0 +1,132 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+
+; ,open architecture primitives low-level locations debug-data syntactic
+
+; July 5th
+;total number of 3-vectors: 10896
+;probably table entries: 10381
+;symbol keys: 7363
+;integer keys: 3018
+;symbol values: 3793
+;location values: 2062
+;pair values: 1723
+;operator values: 989
+;debug-data values: 1208
+;transform values: 510
+;            pair   4039   48468
+;          symbol   1067    8536
+;          vector   4477  124132
+;         closure   1541   18492
+;        location    807    9684
+;            port      2      40
+;           ratio      0       0
+;          record    579   16732
+;    continuation      6     136
+; extended-number      0       0
+;        template    985   23916
+;    weak-pointer     33     264
+;        external      0       0
+;unused-d-header1      0       0
+;unused-d-header2      0       0
+;          string   1207   19338
+;     code-vector    986   51097
+;          double      0       0
+;          bignum      0       0
+;           total  15729  320835
+
+
+(define (analyze-3-vectors)
+  (collect)
+  (let ((vs (find-all (enum stob vector)))
+	(total 0)
+	(table-entries 0)
+	(symbol-keys 0)
+	(int-keys 0)
+	(symbols 0)
+	(locations 0)
+	(debug-datas 0)
+	(pairs 0)
+	(operators 0))
+    (set! *foo* '())
+    (vector-for-each
+     (lambda (v)
+       (if (= (vector-length v) 3)
+	   (let ((x (vector-ref v 2)))
+	     (set! total (+ total 1))
+	     (cond ((or (vector? x) (eq? x #f))
+		    (set! table-entries (+ table-entries 1))
+		    (let ((key (vector-ref v 0)))
+		      (cond ((symbol? key)
+			     (set! symbol-keys (+ symbol-keys 1)))
+			    ((integer? key)
+			     (set! int-keys (+ int-keys 1)))))
+		    (let ((val (vector-ref v 1)))
+		      (cond ((symbol? val)
+			     (set! symbols (+ symbols 1)))
+			    ((location? val)
+			     (set! locations (+ locations 1)))
+			    ((pair? val)
+			     (set! pairs (+ pairs 1)))
+			    ((transform? val)
+			     (set! operators (+ operators 1)))
+			    ((debug-data? val)
+			     (set! debug-datas (+ debug-datas 1)))
+			    (else (set! *foo* (cons v *foo*))))))))))
+     vs)
+    (display "total number of 3-vectors: ") (write total) (newline)
+    (display "probably table entries: ") (write table-entries) (newline)
+    (display "symbol keys: ") (write symbol-keys) (newline)
+    (display "integer keys: ") (write int-keys) (newline)
+    (display "symbol values: ") (write symbols) (newline)
+    (display "location values: ") (write locations) (newline)
+    (display "pair values: ") (write pairs) (newline)
+    (display "transform values: ") (write operators) (newline)
+    (display "debug-data values: ") (write debug-datas) (newline)))
+
+(define *foo* '())
+
+(define (bar)
+  (collect)
+  (vector-size-histogram (find-all (enum stob vector))))
+
+(define (vector-size-histogram vs)
+  (write (vector-length vs)) (display " vectors") (newline)
+  (let ((n 0))
+    (vector-for-each (lambda (v)
+		       (if (eq? v vs) 'foo
+			   (if (> (vector-length v) n)
+			       (set! n (vector-length v)))))
+		     vs)
+    (display "longest: ") (write n) (newline)
+    (let ((hist (make-vector (+ n 1) 0)))
+      (vector-for-each (lambda (v)
+			 (let ((l (vector-length v)))
+			   (vector-set! hist l (+ (vector-ref hist l) 1))))
+		       vs)
+      (let loop ((i 0))
+	(if (< i n)
+	    (let ((m (vector-ref hist i)))
+	      (if (> m 0)
+		  (begin (write-padded i 6)
+			 (write-padded m 7)
+			 (write-padded (* (+ (* i m) 1) 4) 7)
+			 (newline)))
+	      (loop (+ i 1))))))))
+
+(define (write-padded x pad)
+  (let ((s (if (symbol? x)
+	       (symbol->string x)
+	       (number->string x))))
+    (do ((i (- pad (string-length s)) (- i 1)))
+	((<= i 0) (display s))
+      (write-char #\space))))
+
+
+(define (vector-for-each proc v)
+  (let ((z (vector-length v)))
+    (do ((i (- z 1) (- i 1)))
+	((< i 0) #f)
+      (if (not (vector-unassigned? v i))
+	  (proc (vector-ref v i))))))
diff --git a/scheme/debug/wind-test.scm b/scheme/debug/wind-test.scm
new file mode 100644
index 0000000..de44e93
--- /dev/null
+++ b/scheme/debug/wind-test.scm
@@ -0,0 +1,52 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+"
+The correct output looks something like this:
+
+wind-1  f: 1
+wind-2  f: 2
+before-throw-out  f: 3
+unwind-2  f: 2
+unwind-1  f: 1
+after-throw-out  f: top
+wind-1  f: 1
+wind-2  f: 2
+after-throw-in  f: 3
+unwind-2  f: 2
+unwind-1  f: 1
+done  f: top
+"
+
+(define (wind-test)
+  (let* ((f (make-fluid 'top))
+	 (report (lambda (foo)
+		   (write foo)
+		   (display "  f: ")
+		   (write (fluid f))
+		   (newline))))
+    ((call-with-current-continuation
+       (lambda (k1)
+	 (let-fluid f 1
+	   (lambda ()
+	     (dynamic-wind
+	      (lambda () (report 'wind-1))
+	      (lambda ()
+		(let-fluid f 2
+		  (lambda ()
+		    (dynamic-wind
+		     (lambda () (report 'wind-2))
+		     (lambda ()
+		       (let-fluid f 3
+			 (lambda ()
+			   (report 'before-throw-out)
+			   (call-with-current-continuation
+			     (lambda (k2)
+			       (k1 (lambda ()
+				     (report 'after-throw-out)
+				     (k2 #f)))))
+			   (report 'after-throw-in)
+			   (lambda () (report 'done)))))
+		     (lambda () (report 'unwind-2))))))
+	      (lambda () (report 'unwind-1))))))))))
+
diff --git a/scheme/env/assem.scm b/scheme/env/assem.scm
new file mode 100644
index 0000000..4cb16a8
--- /dev/null
+++ b/scheme/env/assem.scm
@@ -0,0 +1,420 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Byte-code assembler (Richard's version)
+;
+; This assembler can assemble the output of the disassembler (as long as you
+; add the identifier and the list of free names).
+;
+; (lap <identifier> (<free name> ...) <insts>*)
+; <inst> ::= (<op-code> . <operands>) |
+;            <label> |
+;            (global <identifier>) |
+;            (set-global! <identifier>) |
+;            (local <identifer>) |
+;            (set-local! <identifier>) |
+;            (literal <anything>) | (literal (quote <anything>)) |
+;            (computed-goto <label>* <default-label>)  ; not yet implemented
+; <operand> ::= <number> | <label> | <stob-name> |
+;               (lap <spec> <insts>*) ; only where a template is expected
+;
+; (<free name> ...) is a list of all names used in GLOBAL and SET-GLOBAL!
+; instructions.  These names are required.
+;              
+; QUOTE is optional for literals, unless the value is itself quoted.
+;
+; The assembler uses opcode-arg-specs to check the number and type of arguments
+; to the opcodes.
+
+; ENV is an a-list mapping names to bindings.
+
+(define-compilator 'lap syntax-type
+  (lambda (node level depth cont)
+    (let* ((exp (node-form node))
+	   (bindings (map (lambda (name-node)
+			    (cons (node-form name-node)
+				  (node-ref name-node 'binding)))
+			  (caddr exp)))
+	   (template (compile-lap (cadr exp)
+				  (cdddr exp)
+				  bindings)))
+      (fixup-template-refs! template)
+      (deliver-value (instruction-with-literal (enum op closure) template 0)
+		     cont))))
+
+;----------------
+; To allow for circular templates, templates can be referred to by name
+; (the <identifier> in <spec> above).  This code fixes up the references
+; after assembly is otherwise complete.
+; 
+; The first LABEL recursively finds all named templates.  The second
+; replaces template markers with the appropriate template.
+
+(define (fixup-template-refs! template)
+  (let ((templates '()))
+    (let label ((template template))
+      (if (symbol? (template-info template))
+	  (set! templates (cons (cons (template-info template) template)
+				templates)))
+      (do ((i 0 (+ i 1)))
+	  ((>= i (template-length template)))
+	(if (template? (template-ref template i))
+	    (label (template-ref template i)))))
+    (let label ((template template))
+      (do ((i 0 (+ i 1)))
+	  ((>= i (template-length template)))
+	(let ((x (template-ref template i)))
+	  (cond ((template? x)
+		 (label x))
+		((not (template-marker? x)))
+		((assq (template-marker-name x) templates)
+		 => (lambda (t)
+		      (template-set! template i (cdr t))))
+		(else
+		 (error "no template of this name available"
+			(template-marker-name x)))))))))
+
+; Marking where a template should be inserted.
+
+(define template-marker (cons #f #f))
+
+(define (make-template-marker name)
+  (cons template-marker name))
+
+(define (template-marker? x)
+  (and (pair? x)
+       (eq? (car x) template-marker)))
+
+(define template-marker-name cdr)
+
+;----------------
+
+(define (compile-lap id insts bindings)
+  (segment->template (really-compile-lap insts bindings) id #f #f))
+    
+; Assemble each instruction, keeping track of which ones use labels.
+; STUFF is a list of lists of the form (<inst> <offset> . <preceding-insts>)
+; which indicates that <inst> uses a label, that it begins at <offset>, and is
+; preceded by <preceding-insts>.
+
+(define (really-compile-lap insts bindings)
+  (let loop ((insts insts) (segments '()) (stuff '()) (offset 0) (labels '()))
+    (cond ((null? insts)
+	   (fixup-lap-labels segments stuff labels))
+	  ((pair? (car insts))
+	   (call-with-values
+	    (lambda ()
+	      (assemble-instruction (car insts) bindings))
+	    (lambda (segment label-use?)
+	      (let ((new-offset (+ offset (segment-size segment))))
+		(if label-use?
+		    (loop (cdr insts)
+			  '()
+			  `((,(car insts) ,offset . ,segments) . ,stuff)
+			  new-offset
+			  labels)
+		    (loop (cdr insts)
+			  (cons segment segments)
+			  stuff
+			  new-offset
+			  labels))))))
+	  ((or (symbol? (car insts))
+	       (integer? (car insts)))
+	   (loop (cdr insts) segments stuff offset
+		 (cons (cons (car insts) offset) labels)))
+	  (else
+	   (error "bad LAP instruction" (car insts))))))
+
+; Reassemble the instruction at the beginning of each STUFF list to resolve
+; the label reference and glue everything together using SEQUENTIALLY.  The
+; label code assumes that the machine calculates the label from the end of
+; the instruction.
+
+(define (fixup-lap-labels segments stuff labels)
+  (let loop ((stuff stuff) (segment (apply sequentially (reverse segments))))
+    (if (null? stuff)
+	segment
+	(let* ((data (car stuff))
+	       (inst (car data))
+	       (offset (cadr data))
+	       (segments (cddr data)))
+	  (loop (cdr stuff)
+		(sequentially (apply sequentially (reverse segments))
+			      (reassemble-instruction inst offset labels)
+			      segment))))))
+
+; This returns two values, the assembled instruction and a flag indicating
+; whether or not the instruction used a label.
+
+(define (assemble-instruction inst bindings)
+  (really-assemble-instruction inst bindings (lambda (label) (values 0 0))))
+
+; Same as the above, except that labels are resolved and no flag is returned.
+
+(define (reassemble-instruction inst offset labels)
+  (call-with-values
+   (lambda ()
+     (really-assemble-instruction inst #f (resolve-label offset labels)))
+   (lambda (inst ignore)
+     inst)))
+
+; Return the high and low bytes of the distance between OFFSET and LABEL,
+; using the known label offsets in LABELS.
+
+(define (resolve-label offset labels)
+  (lambda (label)
+    (cond ((assoc label labels)
+	   => (lambda (p)
+		(let ((delta (- (cdr p) offset)))
+		  (values (quotient delta byte-limit)
+			  (remainder delta byte-limit)))))
+	  (else
+	   (error "LAP label is not defined" label)))))
+
+;----------------
+; Actually do some assembly.  A few opcodes need special handling; most just
+; use the argument specifications from the architecture.
+
+(define (really-assemble-instruction inst bindings labels)
+  (let ((opname (car inst))
+	(args (cdr inst)))
+    (cond ((assemble-special-op opname args bindings)
+	   => (lambda (inst)
+		(values inst #f)))
+	  ((name->enumerand opname op)
+	   => (lambda (opcode)
+		(assemble-general-instruction opcode inst bindings labels)))
+	  (else
+	   (error "unknown LAP instruction" inst)))))
+
+; The optional ' is optionally stripped off the argument to LITERAL.
+
+(define (assemble-special-op opname args bindings)
+  (case opname
+    ((literal small-literal)
+     (let* ((arg (car args))
+	    (arg (if (and (pair? arg)
+			  (eq? (car arg) 'quote))
+		     (cadr arg)
+		     arg)))
+       (instruction-with-literal (enum op literal) arg)))
+    ((global)
+     (lap-global #f (car args) bindings))
+    ((set-global!)
+     (lap-global #t (car args) bindings))
+;    ((local)
+;     (if (null? (cdr args))
+;         (lap-local (car args) bindings)
+;         #f))
+;    ((set-local!)
+;     (if (null? (cdr args))
+;         (lap-set-local! (car args) bindings)
+;         #f))
+    ((protocol)
+     (apply instruction
+	    (enum op protocol)
+	    (assemble-protocol args)))
+    (else
+     #f)))
+
+; Lookup NAME in BINDINGS to the location.
+
+(define (lap-global assign? name bindings)
+  (let ((binding (assq bindings name)))
+    (if (not binding)
+	(error "LAP variable is not in free list" name)
+	(let ((binding (cdr binding)))
+	  (cond ((and (binding?  binding)
+		      (pair? (binding-place binding)))
+		 (error "LAP variable is not global" name))
+		(assign?
+		 (instruction-with-location (enum op set-global!)
+					    binding
+					    name
+					    usual-variable-type))
+		(else
+		 (instruction-with-location (enum op global)
+					    binding
+					    name
+					    value-type)))))))
+
+; This no longer works and I doubt if anyone uses it.  To fix it the
+; assembler should fix-up BINDINGS to incorporate LEVEL passed to the
+; compilator.
+
+;; Lookup NAME in BINDINGS and pick out the appropriate local op.
+;
+;(define (lap-local name bindings)
+;  (let ((binding (lookup bindings name)))
+;    (if (and (binding? binding)
+;             (pair? (binding-place binding)))
+;        (let* ((level+over (binding-place binding))
+;               (back (- (environment-level bindings)
+;                        (car level+over)))
+;               (over (cdr level+over)))
+;          (case back
+;            ((0) (instruction (enum op local0) over))
+;            ((1) (instruction (enum op local1) over))
+;            ((2) (instruction (enum op local2) over))
+;            (else (instruction (enum op local) back over))))
+;        (error "LAP local variable is not locally bound" name))))
+;          
+;; Same thing, except that there is only one opcode.
+;
+;(define (lap-set-local! name bindings)
+;  (let ((binding (lookup bindings name)))
+;    (if (and (binding? binding)
+;             (pair? (binding-place binding)))
+;        (let* ((level+over (binding-place binding))
+;               (back (- (environment-level bindings)
+;                        (car level+over)))
+;               (over (cdr level+over)))
+;          (instruction (enum op set-local!)
+;                       back
+;                       (quotient over byte-limit)
+;                       (remainder over byte-limit)))
+;        (error "LAP local variable is not locally bound" name))))
+
+; Assembling protocols.
+
+(define (assemble-protocol args)
+  (if (integer? (car args))
+      (let ((count (car args)))
+	(cond ((not (null? (cdr args)))
+	       (if (not (eq? (cadr args) '+))
+		   (error "unknown assembly protocol" args))
+	       (list two-byte-nargs+list-protocol
+		     (quotient count byte-limit)
+		     (remainder count byte-limit)))
+	      ((<= count maximum-stack-args)
+	       (list count))
+	      (else
+	       (list two-byte-nargs-protocol
+		     (quotient count byte-limit)
+		     (remainder count byte-limit)))))
+      (case (car args)
+	((args+nargs)
+	 (cons args+nargs-protocol (cdr args)))
+	((nary-dispatch)
+	 (cons nary-dispatch-protocol
+	       (parse-nary-dispatch (cdr args))))
+	((big-stack)
+	 (error "can't assemble big-stack protocol"))
+	(else
+	 (error "unknown assembly protocol" args)))))
+
+; This is fairly bogus, because it uses the targets as addresses instead
+; of treating them as labels.  Fixing this is too much work, seeing as
+; no one is likely to use it.
+
+(define (parse-nary-dispatch targets)
+  (let ((results (vector 0 0 0 0)))
+    (warn "LAP compiler treats nary-dispatch targets as addresses, not as labels.")
+    (for-each (lambda (target)
+		(if (and (pair? target)
+			 (pair? (cdr target))
+			 (pair? (cddr target))
+			 (or (eq? (car target) '>2)
+			     (and (integer? (car target))
+				  (<= 0 (car target) 2)))
+			 (eq? (cadr target) '=>)
+			 (integer? (caddr target)))
+		    (vector-set! results
+				 (if (eq? (car target) '>2)
+				     3
+				     (car target))
+				 (caddr target))
+		    (error "bad nary-dispatch label in LAP" target)))
+	      targets)
+    (vector->list results)))
+
+;----------------
+; This returns two values, the assembled instruction and a flag indicating
+; whether or not the instruction used a label.
+
+(define (assemble-general-instruction opcode inst bindings labels)
+  (let ((specs (vector-ref opcode-arg-specs opcode))
+	(args (cdr inst))
+	(finish (lambda (ops label-use?)
+		  (values (apply instruction opcode (reverse ops))
+			  label-use?))))
+    (let loop ((specs specs) (args args) (ops '()) (label-use? #f))
+      (if (null? specs)
+	  (finish ops label-use?)
+	  (case (car specs)
+	    ((index) ; segment.scm allows no other operands if an index is used.
+                     ; All non-template indexed operands should have been taken
+                     ; care of above (probably should fix arch.scm).
+	     (let ((template (if (null? (cdr args))
+				 (make-template-marker (car args))
+				 (compile-lap (car args) (cdr args) bindings))))
+	       (values (instruction-with-final-literal opcode
+						       (reverse ops)
+						       template)
+		       label-use?)))
+	    ((offset)
+	     (let ((label (check-lap-arg args 'label inst)))
+	       (call-with-values
+		(lambda () (labels label))
+		(lambda (high low)
+		  (loop (cdr specs) (cdr args) `(,low ,high . ,ops) #t)))))
+	    ((stob)
+	     (let ((byte (check-lap-arg args 'stob inst)))
+	       (loop (cdr specs) (cdr args) (cons byte ops) label-use?)))
+	    ((nargs byte)
+	     (let ((byte (check-lap-arg args 'byte inst)))
+	       (loop (cdr specs) (cdr args) (cons byte ops) label-use?)))
+	    ((two-bytes)
+	     (let ((number (check-lap-arg args 'byte inst)))
+	       (loop (cdr specs) (cdr args)
+		     `(,(remainder number byte-limit)
+		       ,(quotient number byte-limit)
+		       . ,ops)
+		     label-use?)))
+	    ((junk)
+	     (loop (cdr specs) args (cons 0 ops) label-use?))
+	    (else
+	     (if (or (eq? (car specs) '+)
+		     (integer? (car specs)))
+		 (finish ops label-use?)
+		 (error "LAP internal error, unknown opcode argument specification" (car specs)))))))))
+
+; Compiler doesn't provide this so we hack it up.
+
+(define (instruction-with-final-literal opcode operands literal)
+  (cond ((null? operands)
+	 (instruction-with-literal opcode literal))
+	(else
+	 (sequentially (apply instruction
+			      opcode
+			      (reverse (cdr (reverse operands))))
+		       (instruction-with-literal (car (reverse operands))
+						 literal)))))
+
+; Check that the car of ARGS is an argument of the appropriate type and
+; return it.
+
+(define (check-lap-arg args type inst)
+  (if (null? args)
+      (error "not enough arguments in LAP instruction" inst))
+  (let ((arg (car args)))
+    (case type
+      ((byte)
+       (if (integer? arg)
+	   arg
+	   (error "numeric operand expected in LAP instruction" inst)))
+      ((stob)
+       (cond ((name->enumerand arg stob)
+	      => (lambda (x) x))
+	     (else
+	      (error "unknown STOB argument in LAP instruction" inst))))
+      ((label)
+       (cond ((symbol? arg)
+	      arg)
+	     ((and (pair? arg)
+		   (eq? (car arg) '=>))
+	      (cadr arg))
+	     (else
+	      (error "bad label in LAP instruction" inst))))
+      (else
+       (error "LAP internal error, unknown LAP argument specifier" type)))))
+	    
diff --git a/scheme/env/basic-command.scm b/scheme/env/basic-command.scm
new file mode 100644
index 0000000..dddcad0
--- /dev/null
+++ b/scheme/env/basic-command.scm
@@ -0,0 +1,68 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; run
+
+(define-command-syntax 'run "<exp>" "evaluate an expression" '(expression))
+
+(define (run exp)
+  (evaluate-and-select exp (environment-for-commands)))
+
+; exit-when-done
+
+(define-command-syntax 'exit-when-done "[<status>]"
+  "leave Scheme after all threads finish"
+  '(&opt expression))
+
+(define (exit-when-done . exp-option)
+  (let ((status (if (null? exp-option)
+                    0
+                    (eval (car exp-option) (environment-for-commands)))))
+    (terminate-command-processor! status)))
+
+(define-command-syntax 'exit
+		       "[<status>]"
+		       "leave Scheme now"
+		       '(&opt expression))
+
+(define (exit . exp-option)
+  (let ((status (if (null? exp-option)
+                    0
+                    (eval (car exp-option) (environment-for-commands)))))
+    (scheme-exit-now status)))
+
+; go
+
+(define-command-syntax 'go "<exp>" "leave Scheme via tail recursion"
+  '(expression))
+
+(define (go exp)
+  (let ((env (environment-for-commands)))
+    (exit-command-processor (lambda () (eval exp env)))))
+
+; load
+
+(define-command-syntax 'load "<filename> ..."
+  "load Scheme source file(s)"
+  '(&rest filename))
+
+(define (load . filenames)
+  (let ((env (environment-for-commands)))
+    ;; (with-interaction-environment env
+      ;; (lambda ()
+	(noting-undefined-variables env
+	  (lambda ()
+	    (for-each (lambda (filename)
+			(load-into filename env))
+		      filenames)))));; ))
+
+; help
+
+(define ? help)
+
+(define-command-syntax 'help
+  "[<command-name>]"
+  "list all commands, or give help on a specific command"
+  '(&opt name))
+
+(define-command-syntax '? "[<command-name>]" "same as ,help" '(&opt name))
diff --git a/scheme/env/build.scm b/scheme/env/build.scm
new file mode 100644
index 0000000..8886e0d
--- /dev/null
+++ b/scheme/env/build.scm
@@ -0,0 +1,74 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Commands for writing images.
+
+; A heap image written using ,dump or ,build can be invoked with
+;    s48 -i <filename> [-h <heap size>] [-a <argument>]
+; For images made with ,build <exp> <filename>, <argument> is passed as
+; a string to the procedure that is the result of <exp>.
+
+
+; dump <filename>
+
+(define-command-syntax 'dump "<filename>"
+  "write the current heap to an image file"
+  '(filename &opt form))
+
+(define (dump filename . maybe-info)
+  (let ((info (if (null? maybe-info) "(suspended image)" (car maybe-info)))
+	(context (user-context))
+	(env (environment-for-commands)))
+    (build-image (lambda (arg)
+		   (with-interaction-environment env
+		     (lambda ()
+		       (restart-command-processor arg
+						  context
+						  (lambda ()
+						    (greet-user info))))))
+		 filename)))
+
+; build <exp> <filename>
+
+(define-command-syntax 'build "<exp> <filename>"
+  "build a heap image file with <exp> as entry procedure"
+  '(expression filename))
+
+(define (build exp filename)
+  (build-image (eval exp (environment-for-commands)) filename))
+
+; build-image
+
+(define (build-image start filename)
+  (let ((filename (translate filename)))
+    (write-line (string-append "Writing " filename) (command-output))
+    (write-image filename
+		 (stand-alone-resumer start)
+		 "")
+    #t))
+
+(define (stand-alone-resumer start)
+  (usual-resumer  ;sets up exceptions, interrupts, and current input & output
+   (lambda (arg)
+     (call-with-current-continuation
+       (lambda (halt)
+	 (with-handler (simple-condition-handler halt (current-error-port))
+	   (lambda ()
+	     (start arg))))))))
+
+; Simple condition handler for stand-alone programs.
+
+(define (simple-condition-handler halt port)
+  (lambda (c punt)
+    (cond ((error? c)
+	   (display-condition c port)
+	   (halt 1))
+	  ((warning? c)
+	   (display-condition c port))		;Proceed
+	  ((interrupt? c)
+	   ;; (and ... (= (cadr c) interrupt/keyboard)) ?
+	   (halt 2))
+	  (else
+	   (punt)))))
+
+;(define interrupt/keyboard (enum interrupt keyboard))
diff --git a/scheme/env/command-level.scm b/scheme/env/command-level.scm
new file mode 100644
index 0000000..037a417
--- /dev/null
+++ b/scheme/env/command-level.scm
@@ -0,0 +1,530 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Command levels for the command processor
+
+; The command processor's state is divided into three parts:
+; 1. User context - preserved across dump commands.
+;    This includes the designated user and configuration environments.
+; 2. Session state - one per "login"; not preserved across dump commands.
+;    This includes ## and the command loop's interactive ports.
+; 3. Command levels - one for each different command level.
+;    This includes the threads being run at that level and the condition
+;    that caused the level to be pushed, if any.
+;
+; Each command level has its own threads and scheduling queues.  Only one
+; command level is running at any time.  An exception stops the current
+; level and all its threads.
+
+;----------------
+; User context.
+;
+; The is a symbol table stored in a slot in the session state (see below).
+; *USER-CONTEXT-INITIALIZERS* is a list of (<name> . <initial-value-thunk>)
+; pairs.  The <thunk>s are called to get the initial value of the <name>d
+; slots.
+
+(define (make-user-context)
+  (make-symbol-table))
+  
+(define (initialize-user-context!)
+  (let ((t (user-context)))
+    (for-each (lambda (name+thunk)
+		(table-set! t (car name+thunk) ((cdr name+thunk))))
+	      *user-context-initializers*)
+    t))
+
+(define *user-context-initializers* '())
+
+; Add a new slot to the user context.
+
+(define (user-context-accessor name initializer)
+  (set! *user-context-initializers*
+        (append *user-context-initializers*
+                (list (cons name initializer))))
+  (let ((context (user-context)))
+    (if context
+	(table-set! context name (initializer))))
+  (lambda ()
+    (table-ref (or (user-context)
+		   (error "command interpreter not initialized - no user context"
+			  name))
+	       name)))
+
+(define (user-context-modifier name)
+  (lambda (new)
+    (table-set! (or (user-context)
+		    (error "command interpreter not initialized - no user context"
+			   name))
+		name
+		new)))
+
+; There are a few places that have alternate behavior based on this, but mostly
+; it's used to detect premature uses of the user context.
+
+(define (user-context)
+  (if (session-started?)
+      (real-user-context)
+      #f))
+
+;----------------
+; Session state.
+
+; This is a record stored in the session data.
+; It has the command interpreter's ports, the most recent values returned
+; by a command, an exit status, and the batch-mode and break-on-warnings
+; switches.
+
+(define-record-type session :session
+  (make-session command-thread
+		user-context
+                input-port output-port error-port
+		focus-values
+		exit-status
+		batch-mode? break-on-warnings?)
+  session?
+  (command-thread session-command-thread)
+  (user-context session-user-context)
+  (input-port session-input-port)
+  (output-port session-output-port)
+  (error-port session-error-port)
+  (focus-values session-focus-values set-session-focus-values!)
+  (exit-status session-exit-status set-session-exit-status!)
+  (batch-mode? session-batch-mode? set-session-batch-mode?!)
+  (break-on-warnings? session-break-on-warnings? set-session-break-on-warnings?!))
+
+(define session-slot (make-session-data-slot! #f))
+
+(define (session-started?)
+  (session? (session-data-ref session-slot)))
+
+(define (session-accessor accessor)
+  (lambda () (accessor (session-data-ref session-slot))))
+
+(define (session-modifier modifier)
+  (lambda (new) (modifier (session-data-ref session-slot) new)))
+
+(define command-thread (session-accessor session-command-thread))
+(define real-user-context (session-accessor session-user-context))
+(define command-input (session-accessor session-input-port))
+(define command-output (session-accessor session-output-port))
+(define command-error-output (session-accessor session-error-port))
+(define focus-values (session-accessor session-focus-values))
+(define set-focus-values! (session-modifier set-session-focus-values!))
+(define batch-mode? (session-accessor session-batch-mode?))
+(define set-batch-mode?! (session-modifier set-session-batch-mode?!))
+(define break-on-warnings? (session-accessor session-break-on-warnings?))
+(define set-break-on-warnings?! (session-modifier set-session-break-on-warnings?!))
+(define exit-status (session-accessor session-exit-status))
+(define set-exit-status! (session-modifier set-session-exit-status!))
+
+; Log in
+
+(define (start-new-session context iport oport eport resume-args batch?)
+  (session-data-set! session-slot
+		     (make-session (current-thread)
+				   context
+				   iport oport eport
+				   resume-args
+				   #f            ; no exit status yet
+				   batch?
+				   #f)))         ; don't break on warnings
+
+;----------------
+; Command levels
+
+(define-record-type command-level :command-level
+  (really-make-command-level queue thread-counter dynamic-env
+			     levels throw repl-thunk repl-data paused threads)
+  command-level?
+  (queue command-level-queue)                   ; queue of runnable threads
+  (thread-counter command-level-thread-counter) ; count of extant threads
+  (dynamic-env command-level-dynamic-env)       ; used for spawns
+  (levels command-level-levels)                 ; levels above this one
+  (throw command-level-throw)                   ; exit from this level
+  (repl-thunk command-level-repl-thunk)         ; thunk to (re)start level
+  (repl-data command-level-repl-data set-command-level-repl-data!)
+						; data used by REPL
+  (repl-thread command-level-repl-thread set-command-level-repl-thread!)
+						; thread running the REPL
+  (paused command-level-paused-thread set-command-level-paused-thread!)
+						; thread that pushed next level
+  (threads x-command-level-threads set-command-level-threads!))
+				; lazily generated list of this level's threads
+
+(define (make-command-level repl-thunk repl-data dynamic-env levels throw)
+  (let ((level (really-make-command-level (make-thread-queue)
+					  (make-counter)
+					  dynamic-env
+					  levels
+					  throw
+					  repl-thunk
+					  repl-data
+					  #f      ; paused thread
+					  #f)))   ; undetermined thread list
+    (spawn-repl-thread! level)
+    level))
+
+; Add THUNK as an thread to LEVEL.  The level is stored in the thread so
+; that when it is rescheduled after blocking it can be put on the correct
+; run queue.
+
+(define (spawn-on-command-level level thunk id)    
+  (let ((thread (make-thread thunk (command-level-dynamic-env level) id)))
+    (set-thread-scheduler! thread (command-thread))
+    (set-thread-data! thread level)
+    (enqueue-thread! (command-level-queue level) thread)
+    (increment-counter! (command-level-thread-counter level))
+    thread))
+
+; Add a new REPL thread to LEVEL.
+
+(define (spawn-repl-thread! level)
+  (let ((thread (spawn-on-command-level level
+					(command-level-repl-thunk level)
+					'command-loop)))
+    (set-command-level-repl-thread! level thread)))
+
+; Find all of the threads belonging to LEVEL.  This may be expensive to call
+; and may not return the correct value if LEVEL is currently running.
+
+(define (command-level-threads level)
+  (cond ((and (x-command-level-threads level)
+	      (weak-pointer-ref (x-command-level-threads level)))
+	 => (lambda (x) x))
+	((= 1 (counter-value (command-level-thread-counter level)))
+	 (list (command-level-repl-thread level)))
+	(else
+	 (let ((threads (all-threads)))
+	   (do ((i 0 (+ i 1))
+		(es '() (let ((thread (vector-ref threads i)))
+			  (if (and (thread-continuation thread)
+				   (eq? level (thread-data thread)))
+			      (cons thread es)
+			      es))))
+	       ((= i (vector-length threads))
+		(set-command-level-threads! level (make-weak-pointer es))
+		es))))))
+
+;----------------
+; Entry point
+
+; Starting the command processor.  This arranges for an interrupt if the heap
+; begins to fill up or when a keyboard interrupts occurs, starts a new session,
+; runs an initial thunk and then pushes a command level.
+
+(define (start-command-levels resume-args context
+			      start-thunk repl-thunk repl-data)
+  (notify-on-interrupts (current-thread))
+  (start-new-session (or context (make-user-context))
+		     (current-input-port)
+		     (current-output-port)
+		     (current-error-port)
+		     resume-args
+		     (and (pair? resume-args)
+			  (equal? (car resume-args) "batch")))
+  (if (not context)
+      (initialize-user-context!))
+  (start-thunk)
+  (let ((thunk (really-push-command-level repl-thunk
+					  repl-data
+					  (get-dynamic-env)
+					  '())))
+    (ignore-further-interrupts)
+    thunk))
+
+; If true exceptions cause a new command level to be pushed.
+
+(define push-command-levels?
+  (user-context-accessor 'push-command-levels (lambda () #t)))
+
+(define (notify-on-interrupts thread)
+  (set-interrupt-handler! (enum interrupt keyboard)
+			  (lambda stuff
+			    (schedule-event thread
+					    (enum event-type interrupt)
+					    (enum interrupt keyboard))))
+  (call-before-heap-overflow!
+   (lambda stuff
+     (schedule-event thread
+		     (enum event-type interrupt)
+		     (enum interrupt post-gc))))
+  (call-when-deadlocked!
+   (lambda stuff
+     (schedule-event thread
+		     (enum event-type deadlock)))))
+
+(define (ignore-further-interrupts)
+  (set-interrupt-handler! (enum interrupt keyboard)
+			  (lambda stuff
+			    (apply signal (cons 'interrupt stuff))))
+  (call-before-heap-overflow! (lambda stuff #f))
+  (call-when-deadlocked! #f))
+
+; The number of milliseconds per timeslice in the command interpreter
+; scheduler.  Should be elsewhere?
+
+(define command-quantum 200)
+
+; Grab the current continuation, then make a command level and run it.
+;
+; The double-paren around the CWCC is because it returns a continuation which
+; is the thing to do after the command level exits.
+
+(define (really-push-command-level repl-thunk repl-data dynamic-env levels)
+  ((call-with-current-continuation
+     (lambda (throw)
+       (let ((*out?* #f)
+	     (level (make-command-level repl-thunk repl-data dynamic-env
+					levels throw)))
+	 (dynamic-wind
+	  (lambda ()
+	    (if *out?*
+		(error "can't throw back into a command level" level)))
+	  (lambda ()
+	    (run-command-level level #f))
+	  (lambda ()
+	    (set! *out?* #t)
+	    (terminate-level level))))))))
+
+(define (terminate-level level)
+  (let ((threads (command-level-threads level))
+	(queue (command-level-queue level))
+	(*out?* #f))
+    (for-each (lambda (thread)
+		(if (thread-continuation thread)
+		    (begin
+                      (remove-thread-from-queue! thread)
+		      (interrupt-thread thread
+					(lambda ignore
+					  (terminate-current-thread)))
+		      (enqueue-thread! queue thread))))
+	      threads)
+    (dynamic-wind
+     (lambda ()
+       (if *out?*
+	   (error "can't throw back into a command level" level)))
+     (lambda ()
+       (run-command-level level #t))
+     (lambda ()
+       (set! *out?* #t)
+       (let ((levels (command-level-levels level)))
+	 (if (not (null? levels))
+	     (reset-command-input! (car levels))))))))
+
+(define (reset-command-input! level)
+  (let ((repl (command-level-repl-thread level)))
+    (if repl
+	(interrupt-thread repl
+			  (lambda return-values
+			    (signal 'reset-command-input)
+			    (apply values return-values))))))
+
+(define-condition-type 'reset-command-input '())
+(define reset-command-input? (condition-predicate 'reset-command-input))
+
+; Make sure the input and output ports are available and then run the threads
+; on LEVEL's queue.
+
+(define (run-command-level level terminating?)
+  (if (not terminating?)
+      (begin
+	(set-exit-status! #f)
+	(steal-channel-port! (command-input))
+	(steal-channel-port! (command-output))
+	(steal-channel-port! (command-error-output))))
+  (run-threads
+    (round-robin-event-handler (command-level-queue level)
+			       command-quantum
+			       (unspecific)
+			       (command-level-thread-counter level)
+			       (command-level-event-handler level terminating?)
+			       (command-level-upcall-handler level)
+			       (command-level-wait level terminating?))))
+
+; Handling events.
+; SPAWNED and RUNNABLE events require putting the job on the correct queue.
+; A keyboard interrupt exits when in batch mode and pushes a new command
+; level otherwise.
+
+(define (command-level-event-handler level terminating?)
+  (let ((levels (cons level (command-level-levels level))))
+    (lambda (event args)
+      (enum-case event-type event
+	((spawned)
+	 (spawn-on-command-level level (car args) (cadr args))
+	 #t)
+	((runnable)
+	 (let* ((thread (car args))
+		(level (thread-data thread)))
+	   (cond ((not (command-level? level))
+		  (error "non-command-level thread restarted on a command level"
+			 thread))
+		 ((memq level levels)
+		  (enqueue-thread! (command-level-queue level)
+				   thread))
+		 (else
+		  (warn "dropping thread from exited command level"
+			thread)))
+	   #t))
+	((interrupt)
+	 (if terminating?
+	     (warn "Interrupted while unwinding terminated level's threads."))
+	 (quit-or-push-level (make-condition 'interrupt args) levels)
+	 #t)
+	((deadlock)
+	 (if terminating?
+	     (warn "Deadlocked while unwinding terminated level's threads."))
+ 	 (quit-or-push-level (make-condition 'error (list 'deadlocked))
+ 			     levels)
+	 #t)
+	(else
+	 #f)))))
+
+(define (quit-or-push-level condition levels)
+  (if (batch-mode?)
+      ((command-level-throw (last levels)) (lambda () (lambda () 0)))
+       (really-push-command-level (command-level-repl-thunk (last levels))
+				  condition
+				  (command-level-dynamic-env (car levels))
+				  levels)))
+
+; Wait for events if there are blocked threads, otherwise add a new REPL
+; thread if we aren't on the way out.
+
+(define (command-level-wait level terminating?)
+  (lambda ()
+    (cond ((< 0 (counter-value (command-level-thread-counter level)))
+	   (wait))
+	  ((exit-status)
+	   (exit-levels level (exit-status)))
+	  (terminating?
+	   #f)
+	  (else
+	   (warn "command interpreter has died; restarting")
+	   (spawn-repl-thread! level)
+	   #t))))
+
+; Leave the command-level system with STATUS.
+
+(define (exit-levels level status)
+  (let ((top-level (last (cons level (command-level-levels level)))))
+    ((command-level-throw top-level)
+       (lambda () (lambda () status)))))
+
+; Upcalls:
+; return the current command levels
+;  (command-levels)  ->  list of levels
+; exit from LEVEL and calls THUNK
+;  (throw-to-command-level level thunk)
+; push a new command level
+;  (push-command-level repl-thunk repl-data dynamic-env)
+; stop running a repl
+;  (terminate-repl status)
+
+(define (command-level-upcall-handler level)
+  (let ((levels (cons level (command-level-levels level))))
+    (lambda (thread token args)
+      (cond ((eq? token command-levels-token)
+	     levels)
+	    ((eq? token throw-to-command-level-token)
+	     ; arguments are LEVEL THUNK
+ 	     ((command-level-throw (car args)) (cadr args)))
+	    ((eq? token push-command-level-token)
+	     ; arguments are CALLING-THREAD REPL-THUNK DYNAMIC-ENV
+	     (set-command-level-paused-thread! level (car args))
+ 	     (really-push-command-level (cadr args) (caddr args) (cadddr args)
+ 					levels))
+	    ((eq? token terminate-repl-token)
+	     (set-exit-status! (car args))
+	     (let ((repl-thread (command-level-repl-thread level)))
+	       (if repl-thread
+		   (begin 
+		     (set-command-level-repl-thread! level #f)
+		     (kill-thread! repl-thread)))))
+ 	    ((eq? token repl-data-token)
+ 	     (command-level-repl-data level))
+ 	    ((eq? token set-repl-data!-token)
+ 	     (set-command-level-repl-data! level (car args)))
+	    (else
+	     (propogate-upcall thread token args))))))
+
+(define command-levels-token (list 'command-levels-token))
+(define push-command-level-token (list 'push-command-level-token))
+(define throw-to-command-level-token (list 'throw-to-command-level-token))
+(define terminate-repl-token (list 'terminate-repl-token))
+(define repl-data-token (list 'repl-data-token))
+(define set-repl-data!-token (list 'set-repl-data!-token))
+
+(define (repl-data)
+  (upcall repl-data-token))
+
+(define (set-repl-data! value)
+  (upcall set-repl-data!-token value))
+
+(define (terminate-command-processor! status)
+  (upcall terminate-repl-token status))
+
+(define (command-levels)
+  (upcall command-levels-token))
+
+(define (command-level)
+  (car (command-levels)))
+
+(define (top-command-level)
+  (last (command-levels)))
+
+; Command level control
+
+(define (push-command-level thunk data)
+  (upcall push-command-level-token (current-thread) thunk data (get-dynamic-env)))
+
+(define (throw-to-command-level level thunk)
+  (upcall throw-to-command-level-token level thunk))
+
+; This makes a new level just like the old one.
+
+(define (restart-command-level level)
+  (throw-to-command-level
+   level
+   (lambda ()
+     (really-push-command-level (command-level-repl-thunk level)
+				(command-level-repl-data level)
+				(command-level-dynamic-env level)
+				(command-level-levels level)))))
+
+; Proceed with LEVEL causing RETURN-VALUES to be returned from the
+; PUSH-COMMAND-LEVELS call that started LEVEL.
+
+(define (proceed-with-command-level level . return-values)
+  (throw-to-command-level (level-pushed-from level)
+			  (lambda ()
+			    (apply values return-values))))
+
+; Find the level that was pushed from LEVEL.
+
+(define (level-pushed-from level)
+  (let loop ((levels (command-levels)))
+    (cond ((null? (cdr levels))
+	   (error "level not found" level))
+	  ((eq? level (cadr levels))
+	   (car levels))
+	  (else
+	   (loop (cdr levels))))))
+
+; Kill the thread on LEVEL that caused a new level to be pushed.  This is
+; used when the user wants to continue running the rest of LEVEL's threads.
+; We enqueue the paused thread so that its dynamic-winds will be run.
+
+(define (kill-paused-thread! level)
+  (let ((paused (command-level-paused-thread level)))
+    (if (not paused)
+	(error "level has no paused thread" level))
+    (if (eq? paused (command-level-repl-thread level))
+	(spawn-repl-thread! level))
+    (interrupt-thread paused terminate-current-thread)
+;		      (lambda ignore
+;			(terminate-current-thread)))
+    ;(enqueue-thread! (command-level-queue level) paused)
+    (set-command-level-paused-thread! level #f)))
+
+
diff --git a/scheme/env/command.scm b/scheme/env/command.scm
new file mode 100644
index 0000000..b75e49b
--- /dev/null
+++ b/scheme/env/command.scm
@@ -0,0 +1,487 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Interpreting commands.
+
+; Commands begin with a comma because it's an unshifted key and because
+; someone else (I can't remember who) was already using it as a command
+; prefix.
+
+(define command-prefix #\,)
+
+; Fire up the processor.
+;
+; The double-paren around the WITH-HANDLER is because it returns a
+; thunk which is the thing to do after the command-processor exits.
+;
+; There are two version, one for an initial start and the other for restarting
+; with an existing user context.
+
+(define (start-command-processor resume-args start-thunk)
+  (restart-command-processor resume-args #f start-thunk))
+
+(define (restart-command-processor resume-args context start-thunk)
+  ((with-handler command-loop-condition-handler
+     (lambda ()
+       (start-command-levels resume-args
+			     context
+			     start-thunk
+			     real-command-loop
+			     #f)))))	; no condition
+
+; Entry for initialization & testing.
+
+(define (command-processor command-env resume-args)
+  (start-command-processor resume-args
+			   (lambda ()
+			     (set-user-command-environment! command-env)
+			     unspecific)))
+
+;----------------
+; Command loop
+; Called from:
+;  1. condition handler, 2. abort-to-level, 3. breakpoint
+;
+; The condition is either #F or whatever caused a new command loop to be
+; started.
+
+(define (command-loop condition)
+  (push-command-level real-command-loop condition))
+
+(define command-level-condition command-level-repl-data)
+
+; Install the handler, bind $NOTE-UNDEFINED to keep from annoying the user,
+; display the condition and start reading commands.
+;
+; This has SHOWING-FOCUS-OBJECT inlined by hand to reduce the amount of noise
+; the debugger sees on the stack.
+
+(define (real-command-loop)
+  (let-fluids $note-undefined #f    ;useful
+      (lambda ()
+	(display-command-level-condition (command-level-condition (command-level)))
+	(let loop ()
+	  (let ((command (read-command-carefully (command-prompt)
+						 (form-preferred?)
+						 (command-input)))
+		(focus-before (focus-values)))
+	    (execute-command command)
+	    (let ((focus-after (focus-values)))
+	      (if (not (eq? focus-after focus-before))
+		  (show-command-results focus-after)))
+	    (loop))))))
+
+(define (display-command-level-condition condition)
+  (if condition
+      (display-condition condition (command-output))))
+
+; If #T anything that doesn't start with the command prefix (a comma) is
+; treated as an argument to RUN.  If #F no commas are needed and RUN
+; commands must be explicit.
+
+(define form-preferred?
+  (user-context-accessor 'form-preferred? (lambda () #t)))
+
+; Go up to the previous level or exit if there are no more levels.
+
+(define (pop-command-level)
+  (let ((levels (command-levels)))
+    (if (null? (cdr levels))
+        (cond ((batch-mode?)
+	       ; perhaps this should use scheme-exit-now, but I'm
+	       ; worried that it is what handles normal EOF. (HCC)
+	       (exit-command-processor (lambda () 0)))
+	      ((y-or-n? "Exit Scheme 48" #t)
+	       (exit-command-processor (lambda () 1)))
+	      (else
+	       (abort-to-command-level (car levels))))
+	(let ((level (cadr (command-levels))))
+	  (if (command-level-paused-thread level)
+	      (kill-paused-thread! level))
+	  (proceed-with-command-level level)))))
+
+(define (exit-command-processor thunk)
+  (throw-to-command-level (top-command-level)
+			  (lambda () thunk)))
+
+; Condition handler.
+; For warnings and notes we go stop the current level or continue, for
+; errors and interrupts we stop the level or exit.
+
+(define (command-loop-condition-handler c next-handler)
+  (cond ((or (warning? c)
+	     (note? c))
+         (if (break-on-warnings?)
+             (deal-with-condition c)
+             (begin (force-output (current-output-port)) ; keep synchronous
+	            (display-condition c (current-error-port))
+                    (unspecific))))     ;proceed
+        ((or (error? c) (interrupt? c))
+         (if (batch-mode?)
+             (begin (force-output (current-output-port)) ; keep synchronous
+	            (display-condition c (current-error-port))
+                    (let ((status (if (error? c) 1 2)))
+                      (scheme-exit-now status)))
+             (deal-with-condition c)))
+	((reset-command-input? c)
+	 (unspecific))			;proceed
+        (else                           
+         (next-handler))))
+
+; Stop the current level either by pushing a new one or restarting it.
+; If we restart the current level we save it as the focus object to give
+; the user a chance to figure out what happened.
+
+(define (deal-with-condition c)
+  (if (push-command-levels?)
+      (command-loop c)
+      (let ((level (car (command-levels))))
+	(set-focus-object! level)
+	(display-condition c (command-output))
+	(restart-command-level level))))
+
+(define (abort-to-command-level level)
+  (cond ((eq? level (car (reverse (command-levels))))
+	 (newline (command-output))
+	 (write-line "Top level" (command-output)))
+	(else
+	 (display "Back to " (command-output))))
+  (restart-command-level level))
+
+(define-condition-type 'note '())
+(define note? (condition-predicate 'note))
+
+; The prompt is "level-number environment-id-string> " or just
+; "environment-id-string> " at top level.  The id-string is empty for the
+; current user package and the name of the package otherwise.
+
+(define (command-prompt)
+  (let ((level (- (length (command-levels)) 1))
+	(id (environment-id-string (environment-for-commands))))
+    (string-append (if (= level 0)
+		       ""
+		       (number->string level))
+		   (if (or (= level 0) (= (string-length id) 0))
+		       ""
+		       " ")
+		   id
+		   "> ")))
+
+(define-generic environment-id-string &environment-id-string (env))
+
+(define-method &environment-id-string (env) "")
+
+;----------------
+; Evaluate a form and save its result as the current focus values.
+
+(define (evaluate-and-select form env)
+  (call-with-values (lambda ()
+                      (eval form env))
+    (lambda results
+      (if (or (null? results)
+              (not (null? (cdr results)))
+              (not (eq? (car results) (unspecific))))
+          (set-focus-values! results))
+      (apply values results))))
+
+;----------------
+; Display the focus object if it changes (sort of like emacs's redisplay)
+
+(define (showing-focus-object thunk)
+  (let ((focus-before (focus-values)))
+    (thunk)
+    (let ((focus-after (focus-values)))
+      (if (not (eq? focus-after focus-before))
+          (show-command-results focus-after)))))
+
+(define (focus-object)
+  (let ((v (focus-values)))
+    (if (and (pair? v) (null? (cdr v))) (car v) v)))
+
+(define (set-focus-object! obj)
+  (set-focus-values! (list obj)))
+
+(define (show-command-results results)
+  (cond ((null? results))
+        ((not (null? (cdr results)))
+         (let ((out (command-output)))
+           (display "; " out)
+           (write (length results) out)
+           (display " values" out)
+           (newline out))
+         (for-each show-command-result results))
+        (else ;(not (eq? (car results) (unspecific)))
+         (show-command-result (car results)))))
+
+(define (show-command-result result)
+  (write-carefully (value->expression result)
+                   (command-output))
+  (newline (command-output)))
+
+(define $write-depth (make-fluid -1))
+(define $write-length (make-fluid -1))
+
+(define (write-carefully x port)
+  (if (error? (ignore-errors (lambda ()
+                               (limited-write x port
+                                              (fluid $write-depth)
+                                              (fluid $write-length))
+                               #f)))
+      (display "<Error while printing.>" port)))
+
+;----------------
+; Sentinels - run after every command.
+
+(define *sentinels* '())
+
+(define (run-sentinels)
+  (for-each (lambda (sentinel) (sentinel)) *sentinels*))
+
+(define (add-sentinel! sentinel)
+  (if (not (memq sentinel *sentinels*))
+      (set! *sentinels* (cons sentinel *sentinels*))))
+
+;----------------
+; Commands.
+
+(define environment-for-commands interaction-environment)
+
+(define command-environment
+  (user-context-accessor 'command-environment interaction-environment))
+
+;(define *command-structure* (unspecific))
+;
+;(define (command-structure)
+;  *command-structure*)
+;
+;(define (set-command-structure! structure)  ; called on initial startup
+;  (set! *command-structure* structure))
+
+(define command-syntax-table (make-table))
+(define *command-help* '())
+
+(define (get-command-syntax name)
+  (or (table-ref (user-command-syntax-table) name)
+      (table-ref command-syntax-table name)))
+
+(define (define-command-syntax name help1 help2 arg-descriptions)
+  (table-set! command-syntax-table name arg-descriptions)
+  (if help1
+      (set! *command-help* (add-help *command-help* name help1 help2))))
+
+(define (add-help help name help1 help2)  
+  (insert (list name
+                (string-append (symbol->string name) " " help1)
+                help2)
+          help
+          (lambda (z1 z2)
+            (string<=? (cadr z1) (cadr z2)))))
+
+(define user-command-syntax-table
+  (user-context-accessor 'user-command-syntax-table (lambda () (make-table))))
+
+(define user-command-environment
+  (user-context-accessor 'user-command-environment (lambda () #f)))
+
+(define set-user-command-environment!
+  (user-context-modifier 'user-command-environment))
+
+(define user-command-help
+  (user-context-accessor 'user-command-help (lambda () *command-help*)))
+
+(define set-user-command-help!
+  (user-context-modifier 'user-command-help))
+
+(define (define-user-command-syntax name help1 help2 arg-descriptions)
+  (table-set! (user-command-syntax-table) name arg-descriptions)
+  (if help1
+      (set-user-command-help!
+           (add-help (user-command-help) name help1 help2))))
+
+(define (execute-command command)
+  (run-sentinels)
+  (cond ((eof-object? command)
+         (newline (command-output))
+         (pop-command-level))
+        ((not command))       ; error while reading
+        (else
+         (let* ((name (car command))
+		(proc (eval name (user-command-environment))))
+	   (apply proc (cdr command))))))
+
+;----------------
+; help
+
+(define (help . maybe-id)
+  (if (null? maybe-id)
+      (list-commands)
+      (print-command-help (car maybe-id))))
+
+(define (print-command-help id)
+  (let ((o-port (command-output)))
+    (display #\space o-port)
+    (cond ((assq id (user-command-help))
+           => (lambda (data)
+                (if (form-preferred?) (display command-prefix o-port))
+                (display (cadr data) o-port)
+                (display "    " o-port)
+                (display (caddr data) o-port)))
+          (else
+           (display #\" o-port)
+           (display id o-port)
+           (display #\" o-port)
+           (display #\space o-port)
+           (display "is not a command.")))
+    (newline o-port)))
+
+(define (list-commands)
+  (let ((o-port (command-output))
+        (widest 28)
+        (f? (form-preferred?)))
+    (for-each (lambda (s)
+                (write-line s o-port))
+              '(
+"This is a beta-test version of Scheme 48.  You are interacting with"
+"the command processor.  A command is either a Scheme form to evaluate"
+"or one of the following:"
+""))
+
+    (list-command-help (user-command-help) f? o-port)
+    (for-each (lambda (s)
+                (write-line s o-port))
+              '(
+""
+"Square brackets [...] indicate optional arguments."
+""
+"The expression ## evaluates to the last value displayed by the command"
+"processor."
+                ))))
+
+(define (list-command-help data prefix? o-port)
+  (let* ((strings (map (if prefix?
+                           (lambda (d)
+                             (string-append (command-prefix-string
+                                             command-prefix)
+                                            (cadr d)))
+                           cadr)
+                       data))
+         (count (length strings))
+         (back-half (list-tail strings (quotient (+ 1 count) 2))))
+    (let loop ((s1 strings) (s2 back-half))
+      (cond ((not (eq? s1 back-half))
+             (display #\space o-port)
+             (display (car s1) o-port)
+             (write-spaces (max 1 (- 32 (string-length (car s1)))) o-port)
+             (if (not (null? s2))
+                 (display (car s2) o-port))
+             (newline o-port)
+             (loop (cdr s1) (if (null? s2) s2 (cdr s2))))))))
+                   
+;----------------
+; Utilities
+
+(define (error-form proc args)
+  (cons proc (map value->expression args)))
+
+(define (value->expression obj)         ;mumble
+  (if (or (number? obj) (char? obj) (string? obj) (boolean? obj))
+      obj
+      `',obj))
+
+(define (write-spaces count o-port)
+  (do ((count count (- count 1)))
+      ((<= count 0))
+    (display #\space o-port)))
+
+(define (command-prefix-string prefix)
+  (cond ((string? prefix) prefix)
+        ((char? prefix) (string prefix))
+        ((symbol? prefix) (symbol->string prefix))))
+
+(define (write-line string port)
+  (display string port)
+  (newline port))
+
+(define (y-or-n? question eof-value)
+  (let ((i-port (command-input))
+        (o-port (command-output)))
+    (let loop ((count *y-or-n-eof-count*))
+      (display question o-port)
+      (display " (y/n)? " o-port)
+      (let ((line (read-line i-port)))
+        (cond ((eof-object? line)
+               (newline o-port)
+               (if (= count 0)
+                   eof-value
+                   (begin (display "I'll only ask another " o-port)
+                          (write count o-port)
+                          (display " times." o-port)
+                          (newline o-port)
+                          (loop (- count 1)))))
+              ((< (string-length line) 1) (loop count))
+              ((char=? (string-ref line 0) #\y) #t)
+              ((char=? (string-ref line 0) #\n) #f)
+              (else (loop count)))))))
+
+(define *y-or-n-eof-count* 100)
+
+(define (read-line port)
+  (let loop ((l '()))
+    (let ((c (read-char port)))
+      (if (eof-object? c)
+          c
+          (if (char=? c #\newline)
+              (list->string (reverse l))
+              (loop (cons c l)))))))
+
+(define (greet-user info)
+  (let ((port (command-output)))
+    (display "Welcome to Scheme 48 " port)
+    (display version-info port)
+    (if info
+        (begin (write-char #\space port)
+               (display info port)))
+    (display "." port)
+    (newline port)
+    (write-line "Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees."
+		port)
+    (write-line "Please report bugs to scheme-48-bugs@martigny.ai.mit.edu."
+                port)
+    (if (not (batch-mode?))
+	(write-line "Type ,? (comma question-mark) for help." port))))
+
+; The following is used by the debugger to get an appropriate continuation
+; or list of threads to show the user.
+
+(define thread? (structure-ref threads thread?))
+(define thread-continuation (structure-ref threads-internal thread-continuation))
+
+(define (command-continuation)          ;utility for debugger
+  (let ((obj (focus-object)))
+    (cond ((debug-command-level)
+	   => (lambda (level)
+		(if (command-level-paused-thread level)
+		    (thread-continuation (command-level-paused-thread level))
+		    (let ((threads (command-level-threads level)))
+		      (if (= 1 (length threads))
+			  (thread-continuation (car threads))
+			  #f)))))
+	  (((structure-ref continuations continuation?) obj)
+	   obj)
+	  ((thread? obj)
+	   (thread-continuation obj))
+	  (else #f))))
+
+(define (command-threads)               ;utility for debugger
+  (let ((level (debug-command-level)))
+    (if level
+	(command-level-threads level)
+	#f)))
+
+(define (debug-command-level)  
+  (let* ((obj (focus-object)))
+    (if (command-level? obj)
+	obj
+	(let ((levels (command-levels)))
+	  (if (null? (cdr levels))
+	      #f
+	      (cadr levels))))))
diff --git a/scheme/env/debug.scm b/scheme/env/debug.scm
new file mode 100644
index 0000000..b23c042
--- /dev/null
+++ b/scheme/env/debug.scm
@@ -0,0 +1,571 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Commands for debugging.
+
+; translate
+
+(define-command-syntax 'translate "<from> <to>"
+  "establish file name translation"
+  '(filename filename))
+
+(define translate set-translation!)
+
+; preview  -- show continuations
+
+(define (preview)
+  (let ((cont (command-continuation)))
+    (if cont
+	(display-preview (continuation-preview cont)
+			 (command-output)))))
+
+(define (display-preview preview port)
+  (for-each (lambda (info+pc)
+	      (if (not (fluid-let-continuation-info? (car info+pc)))
+		  (display-template-names (car info+pc) port)))
+	    preview))
+
+(define (display-template-names info port)
+  (let ((names (debug-data-names info)))
+    (display "  " port)
+    (if (null? names)
+	(begin (display "unnamed " port)
+	       (write `(id ,(if (debug-data? info)
+				(debug-data-uid info)
+				info))
+		      port))
+	(let loop ((names names))
+	  (if (car names)
+	      (write (car names) port)
+	      (display "unnamed" port))
+	  (if (and (not (null? (cdr names)))
+		   (cadr names))
+	      (begin (display " in " port)
+		     (loop (cdr names))))))
+    (newline port)))
+
+(define fluid-let-continuation-info?	;Incestuous!
+  (let ((id (let-fluid (make-fluid #f) #f
+	      (lambda ()
+		(primitive-catch (lambda (k)
+				   (template-id
+				    (continuation-template k))))))))
+    (lambda (info) 
+      (eqv? (if (debug-data? info)
+		(debug-data-uid info)
+		info)
+	    id))))
+
+
+(define-command-syntax 'preview ""
+  "show pending continuations (stack trace)"
+  '())
+
+; Proceed
+
+(define (really-proceed vals)
+  (let* ((level (command-level))
+	 (condition (command-level-condition level)))
+    (if (ok-to-proceed? condition)
+	(apply proceed-with-command-level (cadr (command-levels)) vals)
+	(begin
+	  (write-line "No way to proceed from here." (command-output))
+	  (write condition (command-output))
+	  (newline (command-output))))))
+
+(define-command-syntax 'proceed "<exp>" "proceed after an interrupt or error"
+  '(&rest expression))
+
+(define (proceed . exps)
+  (really-proceed (map (lambda (exp)
+			 (eval exp (environment-for-commands)))
+		       exps)))
+
+; Scrutinize the condition to ensure that it's safe to return from the
+; call to RAISE.
+
+(define (ok-to-proceed? condition)
+  (and condition
+       (if (error? condition)
+	   (and (exception? condition)
+		(let ((opcode (exception-opcode condition)))
+		  (or (= opcode (enum op global))
+		      (= opcode (enum op local))
+		      (= opcode (enum op local0))
+		      (= opcode (enum op local1))
+		      (= opcode (enum op local2))
+		      (= opcode (enum op set-global!))
+		      (>= opcode (enum op eq?)))))
+	   #t)))
+
+(define (breakpoint . rest)
+  (command-loop (make-condition 'breakpoint rest)))
+
+(define-condition-type 'breakpoint '())
+(define breakpoint? (condition-predicate 'breakpoint))
+
+; push
+
+(define-command-syntax 'push "" "push command level" '())
+
+(define (push)
+  (command-loop (if (command-level? (focus-object))
+		    (command-level-condition (focus-object))
+		    #f)))
+
+; pop (same as ^D (= end-of-file))
+
+(define-command-syntax 'pop "" "pop command level" '())
+
+(define (pop)
+  (pop-command-level))
+
+; reset
+
+(define (reset)
+  (abort-to-command-level (top-command-level)))
+
+(define-command-syntax 'reset "" "top level" '())
+
+(define (go-to-level n)
+  (let ((levels (reverse (command-levels))))
+    (if (and (integer? n)
+	     (>= n 0)
+	     (< n (length levels)))
+	(abort-to-command-level (list-ref levels n))
+	(write-line "invalid command level" (command-output)))))
+
+(define-command-syntax 'level "<number>" "go to specific command level"
+  '(expression))
+
+(define level go-to-level)
+
+(define-command-syntax 'condition ""
+  "select an object that describes the current error condition"
+  '())
+
+(define (condition)
+  (let ((c (command-level-condition (command-level))))
+    (if c
+	(set-focus-object! c)
+	(write-line "no condition" (command-output)))))
+
+; Commands that toggle various flags.
+
+(define (toggle-command get set description)
+  (lambda maybe-option
+    (let ((b (if (null? maybe-option)
+		 (not (get))
+		 (case (car maybe-option)
+		   ((off) #f)
+		   ((on) #t)
+		   ((?) (get))
+		   (else (error "invalid setting (should be on or off or ?)"
+				(car maybe-option))))))
+	  (out (command-output)))
+      (set b)
+      (display (if b "Will " "Won't ") out)
+      (display description out)
+      (newline out))))
+
+(define syntax-for-toggle '(&opt name))
+
+; Batch mode
+
+(define-command-syntax 'batch "[on | off]"
+  "enable/disable batch mode (no prompt, errors exit)"
+  syntax-for-toggle)
+
+(define batch
+  (toggle-command batch-mode?
+		  set-batch-mode?!
+		  "exit on errors"))
+
+; Benchmark mode (i.e., inline primitives)
+
+(define-command-syntax 'bench "[on | off]"
+  "enable/disable benchmark mode (integrate primitives)"
+  syntax-for-toggle)
+
+(define bench
+  (toggle-command (lambda ()
+		    (package-integrate? (environment-for-commands)))
+		  (lambda (b)
+		    (set-package-integrate?! (environment-for-commands) b))
+		  "compile some calls in line"))
+
+; Break on warnings
+
+(define-command-syntax 'break-on-warnings "[on | off]"
+  "treat warnings as errors"
+  syntax-for-toggle)
+
+(define break-on-warnings
+  (toggle-command break-on-warnings?
+		  set-break-on-warnings?!
+		  "enter breakpoint on warnings"))
+
+
+(define-command-syntax 'form-preferred "[on | off]"
+  "enable/disable form-preferred command processor mode"
+  syntax-for-toggle)
+
+(define form-preferred
+  (toggle-command (user-context-accessor 'form-preferred? (lambda () #t))
+		  (user-context-modifier 'form-preferred?)
+		  "prefer forms to commands"))
+
+(define-command-syntax 'levels "[on | off]"
+  "disable/enable command levels"
+  syntax-for-toggle)
+
+(define levels
+  (toggle-command (user-context-accessor 'push-command-levels (lambda () #t))
+		  (user-context-modifier 'push-command-levels)
+		  "push command level on errors"))
+
+
+; Flush debug data base
+
+(define-command-syntax 'flush "[<kind> ...]"
+  "start forgetting debug information
+Kind should be one of: names maps files source tabulate
+ location-names file-packages"
+  '(&rest name))
+
+(define (flush . kinds)
+  (cond ((null? kinds)
+	 (write-line "Flushing location names and tabulated debug info"
+		     (command-output))
+	 (flush-location-names)
+	 ((debug-flag-modifier 'table) (make-table)))
+	(else
+	 (for-each (lambda (kind)
+		     (cond ((memq kind debug-flag-names)
+			    ((debug-flag-modifier kind)
+			     (if (eq? kind 'table) (make-table) #f)))
+			   ((eq? kind 'location-names)
+			    (flush-location-names))
+			   ((eq? kind 'file-packages)
+			    (forget-file-environments))
+			   (else
+			    (write-line "Unrecognized debug flag"
+					(command-output)))))
+		   kinds))))
+
+; Control retention of debugging information
+
+(define-command-syntax 'keep "[<kind> ...]"
+  "start remembering debug information
+Kind should be one of: names maps files source tabulate"
+  '(&rest name))
+
+(define (keep . kinds)
+  (let ((port (command-output)))
+    (if (null? kinds)
+	(for-each (lambda (kind)
+		    (if (not (eq? kind 'table))
+			(begin
+			  (display (if ((debug-flag-accessor kind))
+				       "+ " "- ")
+				   port)
+			  (display kind port)
+			  (newline port))))
+		  debug-flag-names)
+	(for-each (lambda (kind)
+		    (if (and (memq kind debug-flag-names)
+			     (not (eq? kind 'table)))
+			((debug-flag-modifier kind) #t)
+			(write-line "Unrecognized debug flag"
+				    port)))
+		  kinds))))
+
+
+; Collect some garbage
+
+(define (collect)
+  (let ((port (command-output))
+	(before (memory-status memory-status-option/available #f)))
+    ((structure-ref primitives collect))
+    (let ((after (memory-status memory-status-option/available #f)))
+      (display "Before: " port)
+      (write before port)
+      (display " words free in semispace")
+      (newline)
+      (display "After:  " port)
+      (write after port)
+      (display " words free in semispace")
+      (newline))))
+
+(define memory-status-option/available (enum memory-status-option available))
+
+(define-command-syntax 'collect "" "invoke the garbage collector" '())
+
+; Undefined (this is sort of pointless now that NOTING-UNDEFINED-VARIABLES
+; exists)
+;
+;(define (show-undefined-variables)
+;  (let ((out (command-output))
+;        (undef (undefined-variables (environment-for-commands))))
+;    (if (not (null? undef))
+;        (begin (display "Undefined: " out)
+;               (write undef out)
+;               (newline out)))))
+;
+;(define-command-syntax 'undefined "" "list undefined variables"
+;  '() show-undefined-variables)
+
+
+
+; Trace and untrace
+
+(define traced-procedures
+  (user-context-accessor 'traced (lambda () '())))
+(define set-traced-procedures!
+  (user-context-modifier 'traced))
+
+(define (trace . names)
+  (if (null? names)
+      (let ((port (command-output)))
+	(write (map car (traced-procedures)) port)
+	(newline port))
+      (for-each trace-1 names)))
+
+(define-command-syntax 'trace "<name> ..."
+  "trace calls to given procedure(s)"
+  '(&rest name))
+
+(define (untrace . names)
+  (if (null? names)
+      (for-each untrace-1 (map car (traced-procedures)))
+      (for-each untrace-1 names)))
+
+(define-command-syntax 'untrace "<name> ..." "stop tracing calls"
+  '(&rest name))
+
+; Trace internals
+
+(define (trace-1 name)
+  (let* ((env (environment-for-commands))
+	 (proc (environment-ref env name))
+	 (traced (make-traced proc name)))
+    (set-traced-procedures!
+		(cons (list name traced proc env)
+		      (traced-procedures)))
+    (environment-define! env name traced))) ;was environment-set!
+	   
+; Should be doing clookup's here -- avoid creating new locations
+
+(define (untrace-1 name)
+  (let ((probe (assq name (traced-procedures))))
+    (if probe
+	(let* ((traced (cadr probe))
+	       (proc (caddr probe))
+	       (env (cadddr probe)))
+	  (if (eq? (environment-ref env name) traced)
+	      (environment-set! env name proc)
+	      (let ((out (command-output)))
+		(display "Value of " out)
+		(write name out)
+		(display " changed since ,trace; not restoring it." out)
+		(newline out)))
+	  (set-traced-procedures!
+		      (filter (lambda (x)
+				(not (eq? (car x) name)))
+			      (traced-procedures))))
+	(write-line "?" (command-output)))))
+
+(define (make-traced proc name)
+  (lambda args
+    (apply-traced proc name args)))
+
+(define *trace-depth* 8)
+(define (apply-traced proc name args)
+  (let ((port (command-output)))
+    (dynamic-wind
+     (lambda ()
+       (display "[" port))
+     (lambda ()
+       (let-fluids $write-length *trace-depth*
+	 $write-depth *trace-depth*
+	 (lambda ()
+	   (display "Enter " port)
+	   (write-carefully (error-form name args) port)
+	   (newline port)))
+       (call-with-values (lambda ()
+			   (apply proc args))
+	 (lambda results
+	   (let-fluids $write-length *trace-depth*
+	     $write-depth (- *trace-depth* 1)
+	     (lambda ()
+	       (display " Leave " port)
+	       (write-carefully name port)
+	       (for-each (lambda (result)
+			   (display " " port)
+			   (write-carefully (value->expression result) port))
+			 results)))
+	   (apply values results))))
+     (lambda ()
+       (display "]" port)
+       (newline port)))))
+
+; Timer stuff.
+
+(define (time command)
+  (let ((thunk (if (eq? (car command) 'run)
+		   (eval `(lambda () ,(cadr command))
+			 (environment-for-commands))
+		   (lambda () (execute-command command))))
+	(port (command-output)))
+    (let ((start-run-time (run-time))
+	  (start-real-time (real-time)))
+      (call-with-values thunk
+	(lambda results
+	  (let ((stop-run-time (run-time))
+		(stop-real-time (real-time)))
+	    (display "Run time: " port)
+	    (write-hundredths (- stop-run-time start-run-time) port)
+	    (display " seconds; Elapsed time: " port)
+	    (write-hundredths (- stop-real-time start-real-time) port)
+	    (display " seconds" port)
+	    (newline port)
+	    (set-focus-values! results)))))))
+
+; N is in milliseconds
+
+(define (write-hundredths n port)
+  (let ((n (round (quotient n 10))))
+    (write (quotient n 100) port)
+    (write-char #\. port)
+    (let ((r (remainder n 100)))
+      (if (< r 10)
+	  (write-char #\0 port))
+      (write r port))))
+
+(define-command-syntax 'time "<command>" "measure execution time"
+  '(command))
+
+; Support for stuffing things from Emacs.
+
+(define-command-syntax 'from-file #f #f	;"<filename>" "editor support"
+  '(&opt filename))
+
+(define-command-syntax 'end #f #f
+  '())
+
+(define (from-file . maybe-filename)
+  (let* ((filename (if (null? maybe-filename) #f (car maybe-filename)))
+	 (env (let ((probe (if filename
+			       (get-file-environment filename)
+			       #f))
+		    (c (environment-for-commands)))
+		(if (and probe (not (eq? probe c)))
+		    (let ((port (command-output)))
+		      (newline port)
+		      (display filename port)
+		      (display " => " port)
+		      (write probe port)
+		      (display " " port) ;dots follow
+		      probe)
+		    c)))
+	 (in (command-input))
+	 (forms (let recur ()
+		  (let ((command (read-command #f #t in)))
+		    (if (eof-object? command)
+			'()
+			(case (car command)
+			  ((end) '())
+			  ((#f run) (cons (cadr command) (recur)))
+			  (else
+			   (error "unusual command in ,from-file ... ,end"
+				  command))))))))
+    (if (package? env)
+	(with-interaction-environment env
+	  (lambda ()
+	    (noting-undefined-variables env
+	      (lambda ()
+		(eval-from-file forms env (if (null? maybe-filename)
+					      #f
+					      (car maybe-filename)))))
+	    (newline (command-output))))
+	(for-each (lambda (form) (eval form env)) ;Foo
+		  env))))
+
+; Filename -> environment map.
+
+(define file-environments
+  (user-context-accessor 'file-environments (lambda () '())))
+
+(define set-file-environments!
+  (user-context-modifier 'file-environments))
+
+(define (forget-file-environments)
+  (set-file-environments! '()))
+
+(define (note-file-environment! filename env)
+  (if (user-context)
+      (let* ((translated ((structure-ref filenames translate) filename))
+	     (envs (file-environments))
+	     (probe (or (assoc filename envs) ;What to do?
+			(assoc translated envs))))
+	(if probe
+	    (if (not (eq? env (weak-pointer-ref (cdr probe))))
+		(let ((port (command-output)))
+		  (newline port)
+		  (display "Changing default package for file " port)
+		  (display filename port)
+		  (display " from" port)
+		  (newline port)
+		  (write (weak-pointer-ref (cdr probe)) port)
+		  (display " to " port)
+		  (write env port)
+		  (newline port)
+		  (set-cdr! probe (make-weak-pointer env))))
+	    (set-file-environments!
+	     (cons (cons filename (make-weak-pointer env))
+		   envs))))))
+
+(define (get-file-environment filename)
+  (let ((probe (assoc filename (file-environments)))) ;translate ?
+    (if probe
+	(weak-pointer-ref (cdr probe))
+	#f)))
+
+(set-fluid! $note-file-package note-file-environment!)
+
+(define-command-syntax 'forget "<filename>"
+  "forget file/package association"
+  '(filename))
+
+(define (forget filename)
+  (note-file-environment! filename #f))
+
+; ,bound? <name>
+
+(define-command-syntax 'bound? "<name>"
+  "display binding of name, if any"
+  '(name))
+
+(define (bound? name)
+  (let ((port (command-output))
+	(probe (package-lookup (environment-for-commands) name)))
+    (if probe
+	(begin (display "Bound to " port)
+	       (write probe)
+	       (newline port))
+	(write-line "Not bound" port))))
+
+; ,expand <form>
+
+(define-command-syntax 'expand "[<form>]"
+  "macro-expand a form"
+  '(&opt expression))
+
+(define (expand . maybe-exp)
+  (let ((exp (if (null? maybe-exp)
+		 (focus-object)
+		 (car maybe-exp)))
+	(env (package->environment (environment-for-commands))))
+    (set-focus-object!
+     (schemify ((structure-ref syntactic expand-form) exp env)
+	       env))))
diff --git a/scheme/env/debuginfo.scm b/scheme/env/debuginfo.scm
new file mode 100644
index 0000000..d238068
--- /dev/null
+++ b/scheme/env/debuginfo.scm
@@ -0,0 +1,76 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Reading/writing debugging info
+
+(define (write-debug-info location-info file)
+  (call-with-output-file file
+    (lambda (port)
+
+      (display "Writing ") (display file) (newline)
+      (let ((write-table
+	     (lambda (table comment)
+	       (display "; " port) (display comment port) (newline port)
+	       (table-walk (lambda (key datum)
+			     (write (list key datum) port)
+			     (newline port))
+			   table)
+	       (write '- port) (newline port))))
+	(write-table package-name-table "Package uid -> name")
+	(write-table location-info "Location uid -> (name . package-uid)"))
+
+      (display "; Template uid -> name, parent, pc in parent, env maps" port)
+      (newline port)
+      (table-walk (lambda (id data)
+		    ;; Fields: (uid name parent pc-in-parent
+		    ;;	        env-maps source)
+		    (write (list id
+				 (let ((name (debug-data-name data)))
+				   (if (generated? name)
+				       (name->symbol name)
+				       name))
+				 (let ((p (debug-data-parent data)))
+				   ;; we'd like to (note-debug-data! p)
+				   (if (debug-data? p)
+				       (debug-data-uid p)
+				       p))
+				 (debug-data-pc-in-parent data)
+				 (debug-data-env-maps data)
+				 ;; Don't retain source code, right?
+				 )
+			   port)
+		    (newline port))
+		  (debug-data-table))
+      (write '- port) (newline port))))
+
+(define (read-debug-info file)
+  (call-with-input-file file
+    (lambda (port)
+
+      (display "Reading ") (display file) (newline)
+
+      (let ((read-table
+	     (lambda (table)
+	       (let loop ()
+		 (let ((z (read port)))
+		   (if (pair? z)
+		       (begin (table-set! table
+					  (car z)
+					  (make-immutable! (cadr z)))
+			      ;; (set! *location-uid*
+			      ;;       (max *location-uid* (+ (car z) 1)))
+			      (loop))))))))
+	(read-table package-name-table)
+	(read-table location-info-table))
+
+      (let loop ()
+	(let ((z (read port)))
+	  (if (pair? z)
+	      (begin ;; (set! *template-uid*
+		     ;;	      (max *template-uid* (+ (car z) 1)))
+		     (table-set! (debug-data-table)
+				 (car z)
+				 (make-immutable!
+				  (apply make-debug-data
+					 (append z '(())))))
+		     (loop))))))))
diff --git a/scheme/env/disasm.scm b/scheme/env/disasm.scm
new file mode 100644
index 0000000..18c07cd
--- /dev/null
+++ b/scheme/env/disasm.scm
@@ -0,0 +1,249 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This is file assem.scm.
+
+;;;; Disassembler
+
+; This defines a command processor command
+;      dis <expression>
+; that evaluates <expression> to obtain a procedure or lambda-expression,
+; which is then disassembled.
+
+; Needs:
+;   template? template-name template-code
+;   closure? closure-template
+;   code-vector-...
+;   location-name
+
+; The assembly language is designed to be rereadable.  See env/assem.scm.
+
+(define-command-syntax 'dis "[<exp>]" "disassemble procedure"
+  '(&opt expression))
+
+; The command.  The thing to be disassembled defaults to the focus object (##).
+
+(define (dis . maybe-exp)
+  (disassemble (if (null? maybe-exp)
+		   (focus-object)
+		   (eval (car maybe-exp) (environment-for-commands)))))
+
+(define (disassemble obj)
+  (really-disassemble (coerce-to-template obj) 0)
+  (newline))
+
+; Instruction loop.  WRITE-INSTRUCTION returns the new program counter.
+
+(define (really-disassemble tem level)
+  (write (template-name tem))
+  (let ((length (template-code-length (template-code tem))))
+    (let loop ((pc 0))
+      (if (< pc length)
+	  (loop (write-instruction tem pc level #t))))))
+
+; The protocol used for procedures that require extra stack space uses three
+; bytes at the end of the code vector.
+
+(define (template-code-length code)
+  (if (and (= (enum op protocol)
+	      (code-vector-ref code 0))
+	   (= big-stack-protocol
+	      (code-vector-ref code 1)))
+      (- (code-vector-length code) 3)
+      (code-vector-length code)))
+
+; Write out the intstruction at PC in TEMPLATE.  LEVEL is the nesting depth
+; of TEMPLATE.  If WRITE-SUB-TEMPLATES? is false we don't write out any
+; templates found.
+;
+; Special handling is required for the few instructions that do not use a
+; fixed number of code-stream arguments.
+
+(define (write-instruction template pc level write-sub-templates?)
+  (let* ((code (template-code template))
+         (opcode (code-vector-ref code pc)))
+    (newline-indent (* level 3))
+    (write-pc pc)
+    (display " (")
+    (write (enumerand->name opcode op))
+    (let ((pc (cond ((= opcode (enum op computed-goto))
+ 		     (display-computed-goto pc code))
+ 		    ((= opcode (enum op make-flat-env))
+ 		     (display-flat-env (+ pc 1) code))
+		    ((= opcode (enum op protocol))
+		     (display-protocol (code-vector-ref code (+ pc 1)) pc code))
+ 		    (else
+ 		     (print-opcode-args opcode pc code template
+ 					level write-sub-templates?)))))
+      (display #\))
+      pc)))
+
+; Write out all of the branches of a computed goto.
+
+(define (display-computed-goto start-pc code)
+  (display #\space)
+  (let ((count (code-vector-ref code (+ start-pc 1))))
+    (write count)
+    (do ((pc (+ start-pc 2) (+ pc 2))
+	 (count count (- count 1)))
+	((= count 0) pc)
+      (display #\space)
+      (write `(=> ,(+ start-pc (get-offset pc code) 2))))))
+
+; Write out the environment specs for the make-flat-env opcode.
+  
+(define (display-flat-env pc code)
+  (let ((total-count (code-vector-ref code (+ 1 pc))))
+    (display #\space) (write total-count)
+    (let loop ((pc (+ pc 2)) (count 0) (old-back 0))
+      (if (= count total-count)
+	  pc
+	  (let ((back (+ (code-vector-ref code pc)
+			 old-back))
+		(limit (+ pc 2 (code-vector-ref code (+ pc 1)))))
+	    (do ((pc (+ pc 2) (+ pc 1))
+		 (count count (+ count 1))
+		 (offsets '() (cons (code-vector-ref code pc) offsets)))
+		((= pc limit)
+		 (display #\space)
+		 (write `(,back ,(reverse offsets)))
+		 (loop pc count back))))))))
+
+; Display a protocol, returning the number of bytes of instruction stream that
+; were consumed.
+
+(define (display-protocol protocol pc code)
+  (display #\space)
+  (+ pc (cond ((<= protocol maximum-stack-args)
+	       (display protocol)
+	       2)
+	      ((= protocol two-byte-nargs-protocol)
+	       (display (get-offset (+ pc 2) code))
+	       4)
+	      ((= protocol two-byte-nargs+list-protocol)
+	       (display (get-offset (+ pc 2) code))
+	       (display " +")
+	       4)
+	      ((= protocol args+nargs-protocol)
+	       (display "args+nargs")
+	       3)
+	      ((= protocol nary-dispatch-protocol)
+	       (display "nary-dispatch")
+	       (do ((i 0 (+ i 1)))
+		   ((= i 4))
+		 (let ((offset (code-vector-ref code (+ pc 2 i))))
+		   (if (not (= offset 0))
+		       (begin
+			 (display #\space)
+			 (display (list (if (= i 3) '>2 i)
+					'=>
+					(+ pc offset)))))))
+	       6)
+	      ((= protocol big-stack-protocol)
+	       (display "big-stack")
+	       (let ((size (display-protocol (code-vector-ref code
+							      (- (code-vector-length code)
+								 3))
+					     pc
+					     code)))
+		 (display #\space)
+		 (display (get-offset (- (code-vector-length code) 2) code))
+		 size))
+	      (else
+	       (error "unknown protocol" protocol)))))
+
+; Generic opcode argument printer.
+
+(define (print-opcode-args op start-pc code template level write-templates?)
+  (let ((specs (vector-ref opcode-arg-specs op)))
+    (let loop ((specs specs) (pc (+ start-pc 1)))
+      (cond ((or (null? specs)
+ 		 (= 0 (arg-spec-size (car specs) pc code)))
+  	     pc)
+  	    ((eq? (car specs) 'junk)  ; avoid printing a space
+	     (loop (cdr specs) (+ pc 1)))
+	    (else
+  	     (display #\space)
+  	     (print-opcode-arg specs pc start-pc code template level write-templates?)
+ 	     (loop (cdr specs) (+ pc (arg-spec-size (car specs) pc code))))))))
+  
+; The number of bytes required by an argument.
+
+(define (arg-spec-size spec pc code)
+  (case spec
+    ((nargs byte stob junk) 1)
+    ((offset index small-index two-bytes) 2)
+    ((env-data) (+ 1 (* 2 (code-vector-ref code pc))))
+    (else 0)))
+
+; Print out the particular type of argument.
+
+(define (print-opcode-arg specs pc start-pc code template level write-templates?)
+  (case (car specs)
+    ((nargs byte)
+     (write (code-vector-ref code pc)))
+    ((two-bytes)
+     (write (get-offset pc code)))
+    ((index)
+     (let ((thing (template-ref template (get-offset pc code))))
+       (write-literal-thing thing level write-templates?)))
+    ((small-index)
+     (let ((thing (template-ref template (code-vector-ref code pc))))
+       (write-literal-thing thing level write-templates?)))
+    ((offset)
+     (write `(=> ,(+ start-pc (get-offset pc code)))))
+    ((stob)
+     (write (enumerand->name (code-vector-ref code pc) stob)))
+    ((env-data)
+     (let ((nobjects (code-vector-ref code pc)))
+       (let loop ((offset (+ pc 1)) (n nobjects))
+ 	 (cond ((not (zero? n))
+ 		(display (list (code-vector-ref code offset)
+ 			       (code-vector-ref code (+ offset 1))))
+ 		(if (not (= n 1))
+ 		    (write-char #\space))
+ 		(loop (+ offset 2) (- n 1)))))))))
+
+(define (write-literal-thing thing level write-templates?)
+  (cond ((location? thing)
+	 (write (or (location-name thing)
+		    `(location ,(location-id thing)))))
+	((not (template? thing))
+	 (display #\')
+	 (write thing))
+	(write-templates?
+	 (really-disassemble thing (+ level 1)))
+	(else
+	 (display "..."))))
+
+;----------------
+; Utilities.
+
+; Turn OBJ into a template, if possible.
+
+(define (coerce-to-template obj)
+  (cond ((template? obj) obj)
+	((closure? obj) (closure-template obj))
+	((continuation? obj) (continuation-template obj))
+	(else (error "expected a procedure or continuation" obj))))
+
+; Fetch the two-byte value at PC in CODE.
+
+(define (get-offset pc code)
+  (+ (* (code-vector-ref code pc)
+	byte-limit)
+     (code-vector-ref code (+ pc 1))))
+
+; Indenting and aligning the program counter.
+
+(define (newline-indent n)
+  (newline)
+  (do ((i n (- i 1)))
+      ((= i 0))
+    (display #\space)))
+
+(define (write-pc pc)
+  (if (< pc 100) (display " "))
+  (if (< pc 10) (display " "))
+  (write pc))
diff --git a/scheme/env/disclosers.scm b/scheme/env/disclosers.scm
new file mode 100644
index 0000000..11fcceb
--- /dev/null
+++ b/scheme/env/disclosers.scm
@@ -0,0 +1,349 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; --------------------
+; DISCLOSE methods
+
+(define-method &disclose ((obj :closure))
+  (let ((id (template-id (closure-template obj)))
+        (name (template-print-name (closure-template obj))))
+    (if name
+        (list 'procedure
+              id
+              ;; A heuristic that sometimes loses.
+;                 (if (and (pair? name)
+;                          (eq? (car name) '#t) ;Curried
+;                          (vector? (closure-env obj)))
+;                     (error-form
+;                       (if (null? (cdddr name))
+;                           (caddr name)
+;                           (cdddr name))
+;                       (reverse (cdr (vector->list (closure-env obj)))))
+;                     name)
+              name)
+        (list 'procedure id))))
+
+(define-method &disclose ((obj :template))
+  (let ((id (template-id obj))
+        (name (template-print-name obj)))
+    (if name
+        (list 'template id name)
+        (list 'template id))))
+
+(define-method &disclose ((obj :location))
+  (cons 'location
+        (cons (location-id obj)
+              (let ((name (location-name obj)))
+                (if (and name (not (eq? name (location-id obj))))
+                    (list name (location-package-name obj))
+                    '())))))
+
+(define-method &disclose ((obj :continuation))
+  (list (if (exception-continuation? obj)
+	    'exception-continuation
+	    'continuation)
+	(list 'pc (continuation-pc obj))
+	(let ((tem (continuation-template obj)))
+	  (or (template-print-name tem) (template-id tem)))))
+  
+(define-method &disclose ((obj :code-vector))
+  (list 'byte-vector (code-vector-length obj))
+; (cons 'code-vector
+;       (let ((z (code-vector-length obj)))
+;         (do ((i (- z 1) (- i 1))
+;              (l '() (cons (code-vector-ref obj i) l)))
+;             ((< i 0) l))))
+  )
+
+(define-method &disclose ((obj :channel))
+  (let ((status (channel-status obj)))
+    (list (cond ((= status (enum channel-status-option closed))
+		 'closed-channel)
+		((or (= status (enum channel-status-option input))
+		     (= status (enum channel-status-option special-input)))
+		 'input-channel)
+		((or (= status (enum channel-status-option output))
+		     (= status (enum channel-status-option special-output)))
+		 'output-channel)
+		(else	; shouldn't happen unless we get out of sync
+		 'unknown-channel))
+	  (channel-id obj))))
+
+(define-method &disclose ((obj :port))
+  (disclose-port obj))
+
+(define (template-print-name tem)
+  (make-print-name (template-names tem)))
+
+(define (make-print-name names)
+  (if (null? names)
+      #f
+      (let ((name (car names))
+            (parent-name (make-print-name (cdr names))))
+        (cond (parent-name
+               `(,(if name name 'unnamed)
+                 in
+                 ,@(if (pair? parent-name) parent-name (list parent-name))))
+              ((string? name) #f)  ;File name
+              (else name)))))
+
+(define (template-file-name tem)
+  (let loop ((names (template-names tem)))
+    (if (null? names)
+        #f
+        (if (string? (car names))
+            (car names)
+            (loop (cdr names))))))
+
+; --------------------
+; Location names
+
+(define (location-info loc)
+  (let ((id (location-id loc)))
+    (if (integer? id)
+        (table-ref location-info-table id)
+        #f)))
+
+(define (location-name loc)
+  (let ((probe (location-info loc)))
+    (if probe
+        (car probe)
+        #f)))
+
+(define (location-package-name loc)
+  (let ((probe (location-info loc)))
+    (if probe
+        (table-ref package-name-table (cdr probe))
+        #f)))
+
+
+; --------------------
+; Condition disclosers
+
+(define *condition-disclosers* '())
+
+(define (define-condition-discloser pred proc)
+  (set! *condition-disclosers*
+        (cons (cons pred proc) *condition-disclosers*)))
+
+(define-method &disclose-condition ((c :pair))
+  (let loop ((l *condition-disclosers*))
+    (if (null? l)
+        (cons (cond ((error? c) 'error)
+                    ((warning? c) 'warning)
+                    (else (car c)))
+              (condition-stuff c))
+        (if ((caar l) c)
+            ((cdar l) c)
+            (loop (cdr l))))))
+
+(define-condition-discloser interrupt?
+  (lambda (c)
+    (list 'interrupt (enumerand->name (cadr c) interrupt))))
+        
+
+; Make prettier error messages for exceptions
+
+(define-condition-discloser exception?
+  (lambda (c)
+    (let ((opcode (exception-opcode c))
+	  (reason (exception-reason c))
+          (args   (exception-arguments c)))
+      ((vector-ref exception-disclosers opcode)
+       opcode
+       reason
+       args))))
+
+(define exception-disclosers
+  (make-vector op-count
+               (lambda (opcode reason args)
+                 (list 'error
+                       "exception"
+		       reason
+                       (let ((name (enumerand->name opcode op)))
+                         (if (>= opcode (enum op eq?))
+                             (error-form name args)
+                             (cons name args)))))))
+
+(define (define-exception-discloser opcode discloser)
+  (vector-set! exception-disclosers opcode discloser))
+
+(let ((disc (lambda (opcode reason args)
+              (let ((loc (car args)))
+                (cons 'error
+                      (cons (if (location-defined? loc)
+                                "unassigned variable"
+                                "undefined variable")
+                            (cons (or (location-name loc) loc)
+                                  (let ((pack
+                                         (location-package-name loc)))
+                                    (if pack
+                                        (list (list 'package pack))
+                                        '())))))))))
+  (define-exception-discloser (enum op global) disc)
+  (define-exception-discloser (enum op set-global!) disc))
+
+(let ((disc (lambda (opcode reason args)
+	      (list 'error
+		    "LETREC variable used before its value has been produced"))))
+  (define-exception-discloser (enum op local0) disc)
+  (define-exception-discloser (enum op local1) disc)
+  (define-exception-discloser (enum op local2) disc)
+  (define-exception-discloser (enum op big-local) disc))
+
+(let ((disc (lambda (opcode reason args)
+	      (list 'error
+		    (case reason
+		      ((bad-procedure)
+		       "attempt to call a non-procedure")
+		      ((wrong-number-of-arguments)
+		       "wrong number of arguments")
+		      ((wrong-type-argument)
+		       "wrong type argument")
+		      (else
+		       (symbol->string reason)))
+		    (map value->expression (cons (car args) (cadr args)))))))
+  (define-exception-discloser (enum op call) disc)
+  (define-exception-discloser (enum op big-call) disc)
+  (define-exception-discloser (enum op move-args-and-call) disc)
+  (define-exception-discloser (enum op with-continuation) disc)
+  (define-exception-discloser (enum op apply) disc)
+  (define-exception-discloser (enum op closed-apply) disc))
+
+(let ((disc (lambda (opcode reason args)
+	      (let ((proc (car args))
+		    (args (cadr args)))
+		(cond (proc
+		       (list 'error
+			     "returning wrong number of values"
+			     (cons proc args)))
+		      ((null? args)
+		       (list 'error
+			     "returning zero values when one is expected"
+			     '(values)))
+		      (else
+		       (list 'error
+			     "returning several values when only one is expected"
+			     (error-form 'values args))))))))
+  (define-exception-discloser (enum op values) disc)
+  (define-exception-discloser (enum op closed-values) disc))
+
+(let ((disc (lambda (opcode reason args)
+              (let ((thing     (car args))
+                    (type-byte (cadr args))
+                    (offset    (caddr args))
+                    (rest      (cdddr args)))
+                (let ((data (assq (enumerand->name type-byte stob)
+                                  stob-data)))
+                  (list 'error
+                        "exception"
+                        (error-form ((if (= opcode
+					    (enum op stored-object-ref))
+                                         car
+                                         cadr)
+                                     (list-ref data (+ offset 3)))
+                                    (cons thing rest))))))))
+  (define-exception-discloser (enum op stored-object-ref) disc)
+  (define-exception-discloser (enum op stored-object-set!) disc))
+
+(let ((disc (lambda (opcode reason args)
+              (let ((type (enumerand->name (car args) stob)))
+                (list 'error
+                      "exception"
+                      (error-form (string->symbol
+                                   ;; Don't simplify this to "make-"  --JAR
+                                   (string-append (symbol->string 'make-)
+                                                  (symbol->string type)))
+                                  (cdr args)))))))
+  (define-exception-discloser (enum op make-vector-object) disc))
+
+(define (vector-exception-discloser suffix)
+  (lambda (opcode reason args)
+    (let ((type (enumerand->name (cadr args) stob)))
+      (list 'error
+            "exception"
+            (error-form (string->symbol
+                         (string-append (symbol->string type)
+                                        "-"
+                                        (symbol->string suffix)))
+                        (cons (car args) (cddr args)))))))
+
+(define-exception-discloser (enum op stored-object-length)
+  (vector-exception-discloser 'length))
+
+(define-exception-discloser (enum op stored-object-indexed-ref)
+  (vector-exception-discloser 'ref))
+
+(define-exception-discloser (enum op stored-object-indexed-set!)
+  (vector-exception-discloser 'set!))
+
+(define-exception-discloser (enum op get-cont-from-heap)
+  (lambda (opcode reason args)
+    (let ((value (car args))
+	  (continuation (cadr args)))
+      (if (not continuation)
+	  (list 'error
+		"exit status is not a small integer"
+		(value->expression value))
+	  (list 'error
+		"returning to a non-continuation"
+		(value->expression continuation))))))
+
+(define-exception-discloser (enum op ascii->char)
+  (lambda (opcode reason args)
+    (let ((value (car args)))
+      `(error
+	"exception"
+	"wrong-type-argument"
+	(ascii->char ,(value->expression value))
+	,@(if (integer? value)
+	      '("note: INTEGER->CHAR doesn't use ASCII; open ASCII and use ASCII->CHAR")
+	      '())))))
+
+; Call-errors should print as (proc 'arg1 'arg2 ...)
+
+(define-condition-discloser call-error?
+  (lambda (c)
+    (list 'error (cadr c) (error-form (caddr c) (cdddr c)))))
+
+; --------------------
+; Associating names with templates
+
+(define (template-debug-data tem)
+  (get-debug-data (template-info tem)))
+
+(define (template-id tem)
+  (let ((info (template-info tem)))
+    (if (debug-data? info)
+      (debug-data-uid info)
+ info)))
+
+(define (template-name tem)
+  (let ((probe (template-debug-data tem)))
+    (if probe
+     (debug-data-name probe)
+       #f)))
+
+(define (template-names tem)
+  (debug-data-names (template-info tem)))
+
+; We can follow parent links to get a full description of procedure
+; nesting: "foo in bar in unnamed in baz"
+
+(define (debug-data-names info)
+  (let ((dd (get-debug-data info)))
+    (if (debug-data? dd)     ;paranoid
+    (cons (debug-data-name dd)
+          (debug-data-names (debug-data-parent dd)))
+      '())))
+
+; --------------------
+; Utilities
+
+(define (error-form proc args)
+  (cons proc (map value->expression args)))
+
+(define (value->expression obj)
+  (if (or (number? obj) (char? obj) (string? obj) (boolean? obj))
+      obj
+      `',obj))
diff --git a/scheme/env/dispcond.scm b/scheme/env/dispcond.scm
new file mode 100644
index 0000000..422f578
--- /dev/null
+++ b/scheme/env/dispcond.scm
@@ -0,0 +1,77 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+
+; Displaying conditions
+
+(define display-condition
+  (let ((display display) (newline newline))
+    (lambda (c port)
+      (if (ignore-errors (lambda ()
+			   (newline port)
+			   (really-display-condition c port)
+			   #f))
+	  (begin (display "<Error while displaying condition.>" port)
+		 (newline port))))))
+
+(define (really-display-condition c port)
+  (let* ((stuff (disclose-condition c))
+	 (stuff (if (and (list? stuff)
+			 (not (null? stuff))
+			 (symbol? (car stuff)))
+		    stuff
+		    (list 'condition stuff))))
+    (display-type-name (car stuff) port)
+    (if (not (null? (cdr stuff)))
+	(begin (display ": " port)
+	       (let ((message (cadr stuff)))
+		 (if (string? message)
+		     (display message port)
+		     (limited-write message port *depth* *length*)))
+	       (let ((spaces
+		      (make-string (+ (string-length
+				       (symbol->string (car stuff)))
+				      2)
+				   #\space)))
+		 (for-each (lambda (irritant)
+			     (newline port)
+			     (display spaces port)
+			     (limited-write irritant port *depth* *length*))
+			   (cddr stuff)))))
+    (newline port)))
+
+(define *depth* 5)
+(define *length* 6)
+
+(define-generic disclose-condition &disclose-condition)
+
+(define-method &disclose-condition (c) c)
+
+
+
+(define (limited-write obj port max-depth max-length)
+  (let recur ((obj obj) (depth 0))
+    (if (and (= depth max-depth)
+	     (not (or (boolean? obj)
+		      (null? obj)
+		      (number? obj)
+		      (symbol? obj)
+		      (char? obj)
+		      (string? obj))))
+	(display "#" port)
+	(call-with-current-continuation
+	  (lambda (escape)
+	    (recurring-write obj port
+	      (let ((count 0))
+		(lambda (sub)
+		  (if (= count max-length)
+		      (begin (display "---" port)
+			     (write-char
+			      (if (or (pair? obj) (vector? obj))
+				  #\)
+				  #\})
+			      port)
+			     (escape #t))
+		      (begin (set! count (+ count 1))
+			     (recur sub (+ depth 1))))))))))))
+
diff --git a/scheme/env/flatload.scm b/scheme/env/flatload.scm
new file mode 100644
index 0000000..fff14b2
--- /dev/null
+++ b/scheme/env/flatload.scm
@@ -0,0 +1,107 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; flatloaded -> load
+
+(define *noisy?* #f)
+
+(define (flatload struct . env-option)
+  (let ((env (if (null? env-option)
+		 (interaction-environment)
+		 (car env-option)))
+	(l '())
+	(set-package-loaded?! set-package-loaded?!))
+    (walk-packages (list struct)
+		   (lambda (p)
+		     (not (package-loaded? p)))
+		   (lambda (file p)
+		     (let* ((fn (package-file-name p))
+			    (file (namestring file
+					      (if fn
+						  (file-name-directory fn)
+						  #f)
+					     *load-file-type*)))
+		       (if *noisy?*
+			   (begin (display #\space) (display file)))
+		       (set! l (cons (lambda () (apply fload file env-option))
+				     l))))
+		   (lambda (forms p)
+		     (set! l (cons (lambda ()
+				     (for-each (lambda (form)
+						 (eval form env))
+					       forms))
+				   l)))
+		   (lambda (p)
+		     (set! l (cons (lambda ()
+				     (set-package-loaded?! p #t))
+				   l))))
+    (for-each (lambda (thunk) (thunk)) (reverse l))
+    (newline)))
+
+(define *source-file-name* "")    ;Cf. alt/config.scm
+(define (fload filename . rest)
+  (let ((save filename))
+    (dynamic-wind (lambda () (set! *source-file-name* filename))
+		  (lambda ()
+		    (apply load filename rest))
+		  (lambda () (set! *source-file-name* save)))))
+
+(define (walk-packages structs process? file-action forms-action after-action)
+  (let ((seen '()))
+    (letrec ((recur
+	      (lambda (s)
+		(let ((p (structure-package s)))
+		  (if (not (memq p seen))
+		      (begin 
+			(set! seen (cons p seen))
+			(if (process? p)
+			    (begin
+			      (if *noisy?*
+				  (begin (newline)
+					 (display "[")
+					 (write (structure-name s))))
+			      ;; (write (structure-name s)) (display " ")
+			      (for-each recur (package-opens p))
+			      (for-each (lambda (name+struct)
+					  (recur (cdr name+struct)))
+					(package-accesses p))
+			      (for-each (lambda (clause)
+					  (case (car clause)
+					    ((files)
+					     (for-each (lambda (f)
+							 (file-action f p))
+						       (cdr clause)))
+					    ((begin)
+					     (forms-action (cdr clause) p))))
+					(package-clauses p))
+			      (after-action p)
+			      (if *noisy?* (display "]"))))))))))
+      (for-each recur structs))
+    (if *noisy?* (newline))
+    seen))
+
+
+; Return list of names of all files needed to build a particular structure.
+; This is handy for creating dependency lists for "make".
+
+(define (all-file-names struct . base-option)
+  (let ((l '())
+	(b '()))
+    (walk-packages base-option
+		   (lambda (p) #t)
+		   (lambda (filename p) #f)
+		   (lambda (forms p) #f)
+		   (lambda (p)
+		     (set! b (cons p b))))
+    (walk-packages (list struct)
+		   (lambda (p)
+		     (not (memq p b)))
+		   (lambda (filename p)
+		     (let ((dir (file-name-directory (package-file-name p))))
+		       (set! l (cons (namestring filename dir *load-file-type*)
+				     l))))
+		   (lambda (forms p)
+		     (display "Package contains (begin ...) clause: ")
+		     (write forms)
+		     (newline))
+		   (lambda (p) #f))
+    (reverse l)))
diff --git a/scheme/env/init-defpackage.scm b/scheme/env/init-defpackage.scm
new file mode 100644
index 0000000..3296bed
--- /dev/null
+++ b/scheme/env/init-defpackage.scm
@@ -0,0 +1,30 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This file has to be loaded into the initial-image before any use of
+; DEFINE-STRUCTURE.  Compare with alt/init-defpackage.scm.
+
+; The procedure given to DEFINE-REFLECTIVE-TOWER-MAKER is called when
+; a DEFINE-STRUCTURE form is evaluated.
+
+(define-reflective-tower-maker
+  (let ((environment-macro-eval
+	  (*structure-ref compiler-envs 'environment-macro-eval))
+	(make-simple-interface
+	  (*structure-ref interfaces 'make-simple-interface))
+	(env (interaction-environment)))
+    (lambda (clauses id)
+      (if (null? clauses)
+	  ;; (make-reflective-tower eval (list scheme) id)
+	  (environment-macro-eval (package->environment env))
+	  (delay
+	    (let ((package (eval `(a-package ,(if id
+						  `(for-syntax ,id)
+						  '(for-syntax))
+					     ,@clauses)
+				 env)))
+	      (ensure-loaded (make-structure package
+					     (lambda ()
+					       (make-simple-interface #f '()))
+					     'for-syntax))
+	      (cons eval package)))))))
diff --git a/scheme/env/inspect.scm b/scheme/env/inspect.scm
new file mode 100644
index 0000000..0b2dbec
--- /dev/null
+++ b/scheme/env/inspect.scm
@@ -0,0 +1,479 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; A dirty little inspector.
+; This breaks abstractions left and right.
+; Look and feel shamelessly plagiarized from the Lucid Lisp inspector.
+
+; Inspector state:
+;    thing    ; object currently being inspected, obtained as (focus-object)
+;    menu     ; cached result of (prepare-menu thing).  This is a list of
+;               lists (<name-or-#f> <value>).
+;    position ; position within menu; modified by M (more) command
+;    stack    ; list of other things
+
+(define-record-type inspector-state inspector-state?
+  (make-inspector-state menu position stack)
+  (menu inspector-state-menu)
+  (position inspector-state-position set-inspector-state-position!)
+  (stack inspector-state-stack))
+
+; The inspector is a distinct REPL with its own state.  This allows the
+; user to continue with the same inspection stack after an error.
+
+(define inspector-state repl-data)
+(define set-inspector-state! set-repl-data!)
+
+(define *menu-limit* 15)	; maximum menu entries
+(define *write-depth* 3)	; limit for recursive writes
+(define *write-length* 5)       ; ditto
+
+; There are three commands for invoking the inspector with different
+; initial objects:
+;   ,inspect           -> focus object
+;   ,inspect <exp>     -> value of <exp>
+;   ,debug             -> continuation of stopped thread(s), preferentially
+;                         chooses the thread with the most recent error
+;   ,threads           -> list of current command level's threads
+
+(define-command-syntax 'inspect "[<exp>]" "invoke the inspector"
+  '(&opt form))
+
+(define-command-syntax 'debug "" "inspect the current continuation" '())
+
+(define-command-syntax 'threads "" "inspect stopped threads" '())
+
+(define (debug)
+  (showing-focus-object
+   (lambda ()
+     (set-focus-object! (or (command-continuation)
+			    (command-threads)))))
+  (inspect))
+
+(define (threads)
+  (showing-focus-object
+   (lambda ()
+     (set-focus-object! (command-threads))))
+  (inspect))
+
+(define (inspect . maybe-exp)
+  (if (not (null? maybe-exp))
+      (with-limited-output
+       (lambda ()
+	 (showing-focus-object
+	  (lambda ()
+	    (evaluate-and-select (car maybe-exp)
+				 (environment-for-commands)))))))
+  (push-command-level inspector
+		      (make-inspector-state (prepare-menu (focus-object))
+					    0
+					    '())))
+
+;----------------
+; Actual entry point for the inspector.  We print the menu and then loop
+; reading commands.
+
+(define (inspector)
+  (present-menu)
+  (let loop ()
+    (let ((command (read-command-carefully "inspect: "
+					   #f  ; command preferred
+					   (command-input)
+					   inspector-commands)))
+      (cond ((eof-object? command)
+	     (newline (command-output))
+	     (proceed-with-command-level (cadr (command-levels))))
+	    ((not command)   ; read command error
+	     (loop))
+	    (else
+	     (with-limited-output
+	      (lambda ()
+		(execute-inspector-command command)))
+	     (loop))))))
+
+(define (present-menu)
+  (let ((state (inspector-state)))
+    (display-menu (inspector-state-menu state)
+		  (inspector-state-position state)
+		  (command-output))))
+
+; Go to a new thing by making a new inspector state.
+
+(define (new-selection thing stack)
+  (set-inspector-state!
+     (make-inspector-state (prepare-menu thing) 0 stack)))
+
+; Selection commands are either an integer, which selects a menu item,
+; or `u' to move up the stack, `d' to move to the next continuation
+; (only valid when the current object is a continuation), or `t' which
+; moves to a procedure's template (only valid when the current object
+; is a template).
+
+(define (read-selection-command port)
+  (let ((x (read port)))
+    (if (or (integer? x)
+	    (memq x '(u d t)))
+	x
+	(read-command-error port "invalid selection command" x))))
+
+(define selection-command-syntax (list '&rest read-selection-command))
+
+(define (inspector-commands name)
+  (if (integer? name)
+      selection-command-syntax
+      (case name
+	((? m q) '())               ; no arguments
+	((u d t) selection-command-syntax)
+	(else #f))))
+
+; Execute a command.
+;
+; We save the current object and state to compare to the new ones to see
+; if we need to display a new menu.  The old object is pushed on the stack
+; only if nothing has been popped off.
+
+(define (execute-inspector-command command)
+  (let ((result-before (focus-object))
+	(state-before (inspector-state)))
+    (showing-focus-object
+     (lambda ()
+       (let ((name (car command)))
+	 (if (integer? name)
+	     (execute-selection-command command)
+	     (case name
+	       ((u d t)
+		(execute-selection-command command))
+	       ((m) (inspect-more))
+	       ((q) (proceed-with-command-level (cadr (command-levels))))
+	       ((?) (inspect-help))
+	       (else (execute-command command)))))))
+    (let ((result-after (focus-object))
+	  (state-after (inspector-state)))
+      (if (not (eq? result-after result-before))
+	  (begin (if (eq? state-after state-before)
+		     (new-selection result-after
+				    (cons result-before
+					  (inspector-state-stack state-before))))
+		 (present-menu))))))
+
+; Choose a new object.
+
+(define (execute-selection-command command)
+  (if (not (null? command))
+      (let ((name (car command)))
+	(if (integer? name)
+	    (let ((menu (inspector-state-menu (inspector-state))))
+	      (if (and (>= name 0)
+		       (< name (length menu)))
+		  (move-to-object! (menu-ref menu name))
+		  (write-line "Invalid choice." (command-output))))
+	    (case name
+	      ((u) (pop-inspector-stack))
+	      ((d) (inspect-next-continuation))
+	      ((t) (select-template))
+	      (else (error "bad selection command" name))))
+	(execute-selection-command (cdr command)))))
+
+; Procedures for the various commands.
+
+(define (move-to-object! object)
+  (new-selection object
+		 (cons (focus-object)
+		       (inspector-state-stack (inspector-state))))
+  (set-focus-object! object))
+
+(define (pop-inspector-stack)
+  (let ((stack (inspector-state-stack (inspector-state))))
+    (if (pair? stack)
+	(begin (new-selection (car stack) (cdr stack))
+	       (set-focus-object! (car stack)))
+	(write-line "Can't go up from here." (command-output)))))
+
+(define (inspect-next-continuation)
+  (if (continuation? (focus-object))
+      (move-to-object! (continuation-parent (focus-object)))
+      (write-line "Can't go down from a non-continuation." (command-output))))
+
+(define (inspect-more)
+  (let* ((state (inspector-state))
+	 (menu (inspector-state-menu state))
+	 (position (inspector-state-position state)))
+    (if (> (length menu) (+ *menu-limit* position))
+	(let ((position (- (+ position *menu-limit*) 1)))
+	  (set-inspector-state-position! state position)
+	  (present-menu))
+	(write-line "There is no more." (command-output)))))
+
+(define (select-template)
+  (move-to-object! (coerce-to-template (focus-object))))
+
+(define (inspect-help)
+  (let ((o-port (command-output)))
+    (for-each (lambda (s) (display s o-port) (newline o-port))
+	      '("q          quit"
+		"u          up stack (= go to previous object)"
+		"d          down stack"
+		"t          template"
+		"<integer>  menu item"
+		"or any command processor command"
+		"multiple u d t <integer> commands can be put on one line"))))
+
+;----------------
+; Menus.
+;
+; A menu is a list of lists (<name-or-#f> <thing>).
+
+(define (menu-ref menu n)
+  (cadr (list-ref menu n)))
+
+; Get a menu for THING.  We know about a fixed set of types.
+
+(define (prepare-menu thing)
+  (cond ((list? thing)
+         (map (lambda (x)
+		(list #f x))
+              thing))
+
+        ((pair? thing)
+         `((car ,(car thing)) (cdr ,(cdr thing))))
+
+        ((vector? thing)
+         (prepare-menu (vector->list thing)))
+
+        ((closure? thing)
+         (prepare-environment-menu
+              (closure-env thing)
+              (get-shape (template-debug-data (closure-template thing))
+                         0)))
+
+	((template? thing)
+	 (prepare-menu (template->list thing)))
+
+        ((continuation? thing)
+         (prepare-continuation-menu thing))
+
+        ((record? thing)
+         (prepare-record-menu thing))
+
+        ((location? thing)
+         `((id ,(location-id thing))
+           (contents ,(contents thing))))
+
+	((weak-pointer? thing)
+	 `((ref ,(weak-pointer-ref thing))))
+
+        (else '())))
+
+(define (template->list template)
+  (do ((i (- (template-length template) 1) (- i 1))
+       (r '() (cons (template-ref template i) r)))
+      ((< i 0) r)))
+
+; Continuation menus have the both the saved operand stack and the
+; save environment, for which names may be available.
+
+(define (prepare-continuation-menu thing)
+  (let ((next (continuation-parent thing)))
+    `(,@(let recur ((c thing))
+	  (if (eq? c next)
+	      '()
+	      (let ((z (continuation-arg-count c)))
+		(do ((i (- z 1) (- i 1))
+		     (l (recur (continuation-cont c))
+			(cons (list #f (continuation-arg c i))
+			      l)))
+		    ((< i 0) l)))))
+      ,@(prepare-environment-menu (continuation-env thing)
+				  (get-shape (continuation-debug-data thing)
+					     (continuation-pc thing))))))
+
+(define (continuation-debug-data thing)
+  (template-debug-data (continuation-template thing)))
+
+; Records that have record types get printed with the names of the fields.
+
+(define (prepare-record-menu thing)
+  (let ((rt (record-type thing))
+        (z (record-length thing)))
+    (if (record-type? rt)
+        (do ((i (- z 1) (- i 1))
+             (f (reverse (record-type-field-names rt)) (cdr f))
+             (l '() (cons (list (car f) (record-ref thing i)) l)))
+            ((< i 1) l))
+        (do ((i (- z 1) (- i 1))
+             (l '() (cons (list #f (record-ref thing i)) l)))
+            ((< i 0) l)))))
+
+; We may have the names (`shape') for environments, in which case they
+; are used in the menus.
+
+(define (prepare-environment-menu env shape)
+  (if (vector? env)
+      (let ((values (rib-values env)))
+        (if (pair? shape)
+            (append (map list (car shape) values)
+                    (prepare-environment-menu (vector-ref env 0)
+                                              (cdr shape)))
+            (append (map (lambda (x)
+			   (list #f x))
+			 values)
+                    (prepare-environment-menu (vector-ref env 0)
+					      shape))))
+      '()))
+
+(define (rib-values env)
+  (let ((z (vector-length env)))
+    (do ((i 1 (+ i 1))
+	 (l '() (cons (if (vector-unassigned? env i)
+			  'unassigned
+			  (vector-ref env i))
+		      l)))
+	((>= i z) l))))
+
+; Returns a list of proper lists describing the environment in effect
+; at the given pc with the given template's code vector.
+;
+; Entries in the environment-maps table (one per template) have the form
+;   #(parent-uid pc-in-parent (env-map ...))
+;
+; Each environment map (one per let or lambda-expression) has the form
+;   #(pc-before pc-after (var ...) (env-map ...))
+;
+; Cf. procedure (note-environment vars segment) in comp.scm.
+
+(define (get-shape dd pc)
+  (if (debug-data? dd)
+      (let loop ((emaps (debug-data-env-maps dd))
+                 (shape (get-shape (get-debug-data
+                                    (debug-data-parent dd))
+                                   (debug-data-pc-in-parent dd))))
+        (if (null? emaps)
+            shape
+            (let ((pc-before (vector-ref (car emaps) 0))
+                  (pc-after  (vector-ref (car emaps) 1))
+                  (vars      (vector-ref (car emaps) 2))
+                  (more-maps (vector-ref (car emaps) 3)))
+              (if (and (>= pc pc-before)
+                       (< pc pc-after))
+                  (loop more-maps
+                        (cons (vector->list vars) shape))
+                  (loop (cdr emaps) shape)))))
+      '()))
+
+;----------------
+; Printing menus.
+;
+; If the current thing is a continuation we print its source code first.
+; Then we step down the menu until we run out or we reach the menu limit.
+
+
+(define (display-menu menu start port)
+  (newline port)
+  (maybe-display-source (focus-object) #f)
+  (let ((menu (list-tail menu start))
+	(limit (+ start *menu-limit*)))
+    (let loop ((i start) (menu menu))
+      (with-limited-output
+       (lambda ()
+	 (cond ((null? menu))
+	       ((and (>= i limit)
+		     (not (null? (cdr menu))))
+		(display " [m] more..." port) (newline port))
+	       (else
+		(let ((item (car menu)))
+		  (display " [" port)
+		  (write i port)
+		  (if (car item)
+		      (begin (display ": " port)
+			     (write-carefully (car item) port)))
+		  (display "] " port)
+		  (write-carefully
+		   (value->expression (cadr item))
+		   port)
+		  (newline port)
+		  (loop (+ i 1) (cdr menu))))))))))
+
+; Exception continuations don't have source, so we get the source from
+; the next continuation if it is from the same procedure invocation.
+
+(define (maybe-display-source thing exception?)
+  (cond ((not (continuation? thing))
+	 (values))
+	((exception-continuation? thing)
+	 (let ((next (continuation-cont thing)))
+	   (if (not (eq? next (continuation-parent thing)))
+	       (maybe-display-source next #t))))
+	(else
+	 (let ((dd (continuation-debug-data thing)))
+	   (if dd
+	       (let ((source (assoc (continuation-pc thing)
+				    (debug-data-source dd))))
+		 (if source
+		     (display-source-info (cdr source) exception?))))))))
+  
+; Show the source code for a continuation, if we have it.
+
+(define (display-source-info info exception?)
+  (if (pair? info)
+      (let ((o-port (command-output))
+	    (i (car info))
+	    (exp (cdr info)))
+	(if (and (integer? i) (list? exp))
+	    (begin
+	      (display (if exception?
+			   "Next call is "
+			   "Waiting for ")
+		       o-port)
+	      (limited-write (list-ref exp i) o-port
+			     *write-depth* *write-length*)
+	      (newline o-port)
+	      (display "  in " o-port)
+	      (limited-write (append (sublist exp 0 i)
+				     (list '^^^)
+				     (list-tail exp (+ i 1)))
+			     o-port
+			     *write-depth* *write-length*)
+	      (newline o-port))))))
+
+;----------------
+; A command to print out the file in which a procedure is defined.
+; Why is this here and not in debug.scm?
+
+(define-command-syntax 'where "[<procedure>]"
+  "show procedure's source file name"
+  '(&opt expression))
+
+(define (where . maybe-exp)
+  (let ((proc (if (null? maybe-exp)
+		  (focus-object)
+		  (eval (car maybe-exp) (environment-for-commands))))
+	(port (command-output)))
+    (if (procedure? proc)
+	(let ((probe (where-defined proc)))
+	  (if probe
+	      (display probe port)
+	      (display "Source file not recorded" port)))
+	(display "Not a procedure" port))
+    (newline port)))
+
+(define (where-defined thing)
+  (let loop ((dd (template-debug-data (closure-template thing))))
+    (if (debug-data? dd)
+	(if (string? (debug-data-name dd))
+	    (debug-data-name dd)
+	    (loop (debug-data-parent dd)))
+	#f)))
+
+;----------------
+; Utilities
+
+(define (coerce-to-template obj)
+  (cond ((template? obj) obj)
+	((closure? obj) (closure-template obj))
+	((continuation? obj) (continuation-template obj))
+	(else (error "expected a procedure or continuation" obj))))
+
+(define (with-limited-output thunk)
+  (let-fluids $write-depth *write-depth*
+              $write-length *write-length*
+    thunk))
+
diff --git a/scheme/env/jar-assem.scm b/scheme/env/jar-assem.scm
new file mode 100644
index 0000000..a827f34
--- /dev/null
+++ b/scheme/env/jar-assem.scm
@@ -0,0 +1,132 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This is file assem.scm.
+
+;;;; Assembler
+
+; Courtesy John Ramsdell.
+
+; LAP syntax is much like that of the output of the disassembler except
+; that global and set-global! take a symbol as an argument, 
+; statements may be labeled, and jump, jump-if-false, and make-cont 
+; may make a forward reference to a label to give an offset.
+;
+; Example: a translation of (define (dog) (if x 0 1)).
+; (define dog
+;   (lap dog
+;     (check-nargs= 0)
+;     (global x)
+;     (jump-if-false 8)
+;     (literal '0)
+;   8 (jump out)
+;     (literal '1)
+; out (return)))
+
+(define-compilator '(lap syntax)
+  (let ((op/closure (enum op closure)))
+    (lambda (node cenv depth cont)
+      (let ((exp (node-form node)))
+	(deliver-value
+	 (instruction-with-template op/closure
+				    (compile-lap (cddr exp) cenv)
+				    (cadr exp))
+	 cont)))))
+
+; Assembler label environments are simply a-lists.
+(define assembler-empty-env '())
+(define (assembler-extend sym val env) (cons (cons sym val) env))
+(define (assembler-lookup sym env)
+  (let ((val (assv sym env)))
+    (if (pair? val) (cdr val) #f)))
+
+(define (compile-lap instruction-list cenv)
+  (assemble instruction-list
+	    assembler-empty-env
+	    cenv))
+
+; ASSEMBLE returns a segment.
+
+(define (assemble instruction-list lenv cenv)
+  (if (null? instruction-list)
+      (sequentially)
+      (let ((instr (car instruction-list))
+	    (instruction-list (cdr instruction-list)))
+	(cond ((pair? instr)		; Instruction
+	       (sequentially
+		(assemble-instruction instr lenv cenv)
+		(assemble instruction-list
+			  lenv
+			  cenv)))
+	      ((or (symbol? instr)	; Label
+		   (number? instr))
+	       (let ((label (make-label)))
+		 (attach-label
+		  label
+		  (assemble instruction-list
+			    (assembler-extend instr label lenv)
+			    cenv))))
+	      (else (error "invalid instruction" instr))))))
+
+; ASSEMBLE-INSTRUCTION returns a segment.
+
+(define (assemble-instruction instr lenv cenv)
+  (let* ((opcode (name->enumerand (car instr) op))
+	 (arg-specs (vector-ref opcode-arg-specs opcode)))
+    (cond ((or (not (pair? arg-specs))
+	       (not (pair? (cdr instr))))
+	   (instruction opcode))
+	  ((eq? (car arg-specs) 'index)
+	   (assemble-instruction-with-index opcode arg-specs (cdr instr) cenv))
+	  ((eq? (car arg-specs) 'offset)
+	   (let ((operand (cadr instr)))
+	     (apply instruction-using-label
+		    opcode
+		    (let ((probe (assembler-lookup operand lenv)))
+		      (if probe
+			  probe
+			  (begin
+			    (syntax-error "can't find forward label reference"
+					  operand)
+			    empty-segment)))
+		    (assemble-operands (cddr instr) arg-specs))))
+	  (else
+	   (apply instruction
+		  opcode
+		  (assemble-operands (cdr instr) arg-specs))))))
+
+; <index> ::= (quote <datum>) | (lap <name> <instr>) | <name>
+
+(define (assemble-instruction-with-index opcode arg-specs operands cenv)
+  (let ((operand (car operands)))
+    (if (pair? operand)
+	(case (car operand)
+	  ((quote)
+	   (instruction-with-literal opcode
+				     (cadr operand)))
+	  ((lap)
+	   (instruction-with-template opcode
+				      (compile-lap (cddr operand))
+				      (cadr operand)))
+	  (else
+	   (syntax-error "invalid index operand" operand)
+	   empty-segment))
+	;; Top-level variable reference
+	(instruction-with-location
+	 opcode
+	 (get-location (lookup cenv operand)
+		       cenv
+		       operand
+		       value-type)))))
+
+(define (assemble-operands operands arg-specs)
+  (map (lambda (operand arg-spec)
+	 (case arg-spec
+	   ((stob) (or (name->enumerand operand stob)
+		       (error "unknown stored object type" operand)))
+	   ((byte nargs) operand)
+	   (else (error "unknown operand type" operand arg-spec))))
+       operands
+       arg-specs))
+
diff --git a/scheme/env/list-interface.scm b/scheme/env/list-interface.scm
new file mode 100644
index 0000000..7dbc296
--- /dev/null
+++ b/scheme/env/list-interface.scm
@@ -0,0 +1,46 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+;  ,open interfaces packages meta-types sort syntactic
+;  ,config scheme
+
+(define (list-interface thing)
+  (cond ((structure? thing)
+	 (list-interface-1 (structure-interface thing)
+			   (lambda (name)
+			     (let ((x (structure-lookup thing name #t)))
+			       (if (binding? x)
+				   (binding-type x)
+				   #f)))))
+	((interface? thing)
+	 (list-interface-1 thing (lambda (name)
+				   (interface-ref thing name))))
+	(else '?)))
+
+(define (list-interface-1 int lookup)
+  (let ((l '()))
+    (for-each-declaration (lambda (name type)
+			    (if (not (memq name l))  ;compound signatures...
+				(set! l (cons name l))))
+			  int)
+    (for-each (lambda (name)
+		(write name)
+		(display (make-string
+			  (max 0 (- 25 (string-length
+					(symbol->string name))))
+			  #\space))
+		(write-char #\space)
+		(write (careful-type->sexp (lookup name)))    ;( ...)
+		(newline))
+	      (sort-list l (lambda (name1 name2)
+			     (string<? (symbol->string name1)
+				       (symbol->string name2)))))))
+
+(define (careful-type->sexp thing)
+  (cond ((not thing) 'undefined)
+	((or (symbol? thing) (null? thing) (number? thing))
+	 thing)     ;?
+	((pair? thing)    ;e.g. (variable #{Type :value})
+	 (cons (careful-type->sexp (car thing))
+	       (careful-type->sexp (cdr thing))))
+	(else (type->sexp thing #t))))
diff --git a/scheme/env/load-package.scm b/scheme/env/load-package.scm
new file mode 100644
index 0000000..b17af4f
--- /dev/null
+++ b/scheme/env/load-package.scm
@@ -0,0 +1,22 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+(define (ensure-loaded . structs)
+  (force-output (current-output-port))		; avoid interleaved output
+  (let ((out (current-noise-port)))
+    (for-each (lambda (package)
+		(display #\[ out)
+		(display (package-name package) out)
+		(with-interaction-environment package
+		  (lambda ()
+		    (invoke-closure
+		      (make-closure (compile-package package)
+				    (package-uid package)))))
+		(set-package-loaded?! package #t)
+		(walk-population check-structure
+				 (package-clients package))
+		(display #\] out)
+		(newline out))
+	      (collect-packages structs
+				(lambda (package)
+				  (not (package-loaded? package)))))))
+
diff --git a/scheme/env/pacman.scm b/scheme/env/pacman.scm
new file mode 100644
index 0000000..a23cbe2
--- /dev/null
+++ b/scheme/env/pacman.scm
@@ -0,0 +1,328 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; PACkage-manipulation comMANds
+
+(add-sentinel! package-system-sentinel)
+
+
+(define (set-environment-for-commands! p)
+  (set-interaction-environment! p)
+  ;; (set-command-level-env! (command-level) p)
+  )
+
+(define user-environment
+  (user-context-accessor 'user-environment interaction-environment))
+(define set-user-environment!
+  (user-context-modifier 'user-environment))
+
+
+(define-command-syntax 'in "<struct> [<command>]"
+  "go to package, or execute single command in package"
+  '(name &opt command))
+
+(define (in name . maybe-command)
+  (if (and (not (null? maybe-command))
+	   (command-just-evaluates-symbol? (car maybe-command)))
+      (set-focus-object! (environment-ref (really-get-package name)
+					  (cadr (car maybe-command))))
+      (in-package (get-package name) maybe-command)))
+
+(define (command-just-evaluates-symbol? command)
+  (and (pair? command)
+       (eq? (car command) 'run)
+       (symbol? (cadr command))))
+
+(define-command-syntax 'new-package "" "make and enter a new package"
+  '())
+
+(define (new-package)
+  (let ((p (make-simple-package (list (get-structure 'scheme))
+				#t    ;unstable?
+				(get-reflective-tower (user-environment))
+				#f)))
+    (set-package-integrate?! p
+			     (package-integrate? (environment-for-commands)))
+    (set-environment-for-commands! p)))
+
+(define (get-reflective-tower env)    ;Returns promise of (eval . env)
+  (environment-macro-eval (if (package? env)
+			      (package->environment env)
+			      env)))	;Mumble
+
+
+; load-package
+
+(define-command-syntax 'load-package "<struct>" "load package's source code"
+  '(name))
+
+(define (load-package name)
+  (ensure-loaded (get-structure name)))
+
+(define-command-syntax 'reload-package "<struct>" "load package's source code again"
+  '(name))
+
+(define (reload-package name)
+  (let ((s (get-structure name)))
+    (if (not (package-unstable? (structure-package s)))
+	(error "read-only structure" s))
+    (set-package-loaded?! (structure-package s) #f)
+    (ensure-loaded s)))
+
+(define-command-syntax 'structure "<name> <interface>"
+  "create new structure over the current package"
+  '(name expression))
+
+(define (structure name interface-expression)
+  (let* ((c (config-package))
+	 (p (environment-for-commands))
+	 (s (make-structure p
+			    (lambda ()
+			      (eval interface-expression c))
+			    name)))
+    ;; (check-structure s)
+    (environment-define! c name s)))
+
+
+(define-command-syntax 'open "<struct> ..." "open a structure"
+  '(&rest name))
+
+(define (open . names)
+  (for-each (lambda (name)
+	      (let* ((c (config-package))
+		     (thunk (lambda () (environment-ref c name)))
+		     (probe (thunk)))
+		(if (structure? probe)
+		    (if (ensure-loaded-query probe)
+			(package-open! (environment-for-commands) thunk)
+			(error "structure not loaded" name))
+		    (error "not a structure" name))))
+	    names))
+
+(define (ensure-loaded-query struct)
+  (let ((p (structure-package struct)))
+    (cond ((or (package-loaded? p)
+	       (and (null? (package-clauses p))
+		    (every (lambda (struct)
+			     (package-loaded? (structure-package struct)))
+			   (package-opens p))))
+	   #t)
+	  ((or (batch-mode?)
+	       (y-or-n? (if (structure-name struct)
+			    (string-append "Load structure "
+					   (symbol->string
+					    (structure-name struct)))
+			    "Load structure")
+			#f))
+	   (ensure-loaded struct)
+	   #t)
+	  (else #f))))
+
+
+(define-command-syntax 'for-syntax "[<command>]"
+  "go to current package's package for syntax"
+  '(&opt command))
+
+(define (for-syntax . maybe-command)
+  (in-package (cdr (force (get-reflective-tower (environment-for-commands))))
+    maybe-command))
+
+
+; ,user  goes to the user initial environment.
+
+(define-command-syntax 'user "[<command>]" "go to user package"
+  '(&opt command))
+
+(define (user . maybe-command)
+  (in-package (user-environment) maybe-command))
+
+(define-command-syntax 'user-package-is "[<struct>]"
+  "designate user package (for ,user command)"
+  '(&opt name))
+
+(define (user-package-is . name-option)
+  (set-user-environment! (if (null? name-option)
+			     (environment-for-commands)
+			     (get-package (car name-option)))))
+
+(define set-user-environment!
+  (user-context-modifier 'user-environment))
+
+
+; Configuration package  (should there be ,load-config as well?)
+
+(define-command-syntax 'config "[<command>]" "go to configuration package"
+  '(&opt command))
+
+(define (config . maybe-command)
+  (in-package (config-package) maybe-command))
+
+(define-command-syntax 'config-package-is "<struct>"
+  "designate configuration package"
+  '(name))
+
+(define (config-package-is name)
+  (set-config-package! (get-package name)))
+
+
+; ,exec  goes to the exec initial environment.
+
+(define-command-syntax 'exec "[<command>]" "go to command execution package"
+  '(&opt command))
+
+(define (exec . maybe-command)
+  (in-package (user-command-environment) maybe-command))
+
+
+; ,undefine foo  removes definition of foo from current package.
+
+(define-command-syntax 'undefine "<name>" "remove definition"
+  '(name))
+
+(define (undefine name)
+  (package-undefine! (interaction-environment) name))
+
+
+; --------------------
+; Auxiliaries for package commands
+
+(define (in-package p maybe-command)
+  (if (null? maybe-command)
+      (set-environment-for-commands! p)
+      (with-interaction-environment p
+	(lambda ()
+	  (let ((command (car maybe-command)))
+	    (if (procedure? command)
+		(command)
+		(execute-command (car maybe-command))))))))
+
+(define config-package
+  (user-context-accessor 'config-package user-environment))
+
+(define set-config-package!
+  (user-context-modifier 'config-package))
+
+
+(define (get-package name)
+  (let ((p (really-get-package name)))
+    (if (package-unstable? p)
+	p
+	(error "read-only structure" p))))
+
+(define (really-get-package name)
+  (let ((s (get-structure name)))
+    (ensure-loaded-query s)
+    (structure-package s)))
+
+(define (get-structure name)
+  (let ((thing (environment-ref (config-package) name)))
+    (cond ((structure? thing) thing)
+	  (else (error "not a structure" name thing)))))
+
+
+; Main entry point, with package setup.
+
+(define (new-command-processor info commands built-in . meta-structs)
+  ;; Argument to ,build command
+  (lambda (arg)
+    (call-with-values (lambda ()
+			(make-user-envs commands built-in meta-structs))
+      (lambda (env init-thunk)
+	(with-interaction-environment env
+	  (lambda ()
+	    (start-command-processor arg
+				     (lambda ()
+				       (init-thunk)
+				       (greet-user info)))))))))
+
+(define (make-user-envs commands built-in meta-structs)
+  (let* ((tower (make-reflective-tower
+		      eval
+		      (list (*structure-ref built-in 'scheme))
+		      'user))
+	 (user (make-user-package built-in tower))
+	 (config-package (make-config-package 'config
+					      tower
+					      built-in
+					      meta-structs))
+	 (exec-package (make-exec-package commands tower built-in)))
+    (values
+     user
+     (lambda ()
+       (set-user-environment! user)
+       (set-config-package! config-package)
+       (set-user-command-environment! exec-package)))))
+
+; User package
+
+(define (make-user-package built-in tower)
+  (let* ((scheme-structure (*structure-ref built-in 'scheme))
+	 (user
+	  (make-simple-package (list scheme-structure)
+			       #t  ;unstable?
+			       tower
+			       'user)))
+    (set-package-integrate?! user #f)
+    user))
+
+; Configuration package
+
+(define (make-config-package name tower built-in meta-structs)
+  (let* ((module-system (*structure-ref built-in 'module-system))
+	 (config
+	  (make-simple-package (cons module-system
+				     (append meta-structs
+					     (list built-in)))
+			       #t  ;unstable?
+			       tower
+			       name)))
+    (set-reflective-tower-maker!
+         config
+	 (lambda (clauses id)
+	   (if (null? clauses)
+	       tower			;?
+	       (delay (let ((p (eval `(a-package ((for-syntax ,id)) ,@clauses)
+				     config)))
+			(ensure-loaded (make-structure p
+						       (lambda () (make-simple-interface #f '()))
+						       'for-syntax))
+			(cons eval p))))))
+    config))
+
+; Exec package
+
+(define (make-exec-package commands tower built-in)
+  (make-simple-package (list commands (*structure-ref built-in 'scheme))
+		       #t		;unstable?
+		       tower
+		       'exec))
+
+; for prompt string
+
+(define-method &environment-id-string ((env :package))
+  (if (eq? env (user-environment))
+      ""
+      (if (symbol? (package-name env))
+	  (symbol->string (package-name env))
+	  (number->string (package-uid env)))))
+
+(define user-environment
+  (user-context-accessor 'user-environment interaction-environment))
+
+; This is only used by misc/remote.scm, which I don't know if anyone uses.
+;
+; Extract a package-specific evaluator from a package.  Eventually, it
+; would be nice if load, eval-from-file, eval-scanned-forms, and
+; perhaps other things were also generic over different kinds of
+; environments.
+;
+;(define funny-name/evaluator (string->symbol ".evaluator."))
+;
+;(define (set-package-evaluator! p evaluator)
+;  (package-define-funny! p funny-name/evaluator evaluator))
+;
+;(define (package-evaluator p)
+;  (or (get-funny (package->environment p) funny-name/evaluator) eval))
+;
+;(define-method &evaluate (form (env :package))
+;  ((package-evaluator env) form env))
diff --git a/scheme/env/pedit.scm b/scheme/env/pedit.scm
new file mode 100644
index 0000000..db61527
--- /dev/null
+++ b/scheme/env/pedit.scm
@@ -0,0 +1,355 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Package / structure / interface mutation operations.
+
+; None of these is essential for the static semantics of packages.
+; They only come into play in order to implement dynamic package
+; mutation, which is solely a debugging operation.
+
+; This is work in progress.  There are surely numerous bugs.
+
+; (define (package-system-sentinel) #f)
+
+(define (package-open! p struct-thunk)
+  (if (not (memq (struct-thunk) (package-opens p)))
+      (let ((thunk (package-opens-thunk p)))
+        (set-package-opens-thunk! p (lambda ()
+                                      (cons (struct-thunk) (thunk))))
+        (reinitialize-package! p)
+        (verify-package p)
+	)))
+
+(define (reinitialize-package! p)
+  (if *debug?*
+      (begin (write `(reinitialize ,p)) (newline)))
+  ;; (set-package-opens! p #f)
+  (if (package-opens-really p)
+      (initialize-package! p)))
+
+(define (reinitialize-structure! s)
+  (if *debug?*
+      (begin (write `(reinitialize ,s)) (newline)))
+  ;; (set-structure-interface! s #f)
+  (if (structure-interface-really s)
+      (initialize-structure! s)))
+
+
+; GET-NEW-LOCATION-CAREFULLY is called to obtain a location when 
+; a variable becomes newly defined.
+; If the variable has already been referenced in any code that ought
+; to see the new binding, we need to alter all such references to
+; access the new location instead of whatever location they saw
+; before.
+
+(define (get-new-location-carefully p name)
+  (let* ((prev (package-lookup p name))
+	 (new (if (binding? prev)
+		  (let ((new (make-new-location p name))
+			(cached (table-ref (package-cached p) name)))
+		    (copy-shadowed-contents! (binding-place prev) new)
+		    (cond (cached
+			   (if (eq? (binding-place prev) cached)
+			       (cope-with-mutation p name new cached)
+			       (error "binding cache inconsistency"
+				      p name new cached))))
+		    new)
+		  (get-new-location-non-shadowing p name)))
+	 (aloc (table-ref (package-undefined-but-assigneds p)
+			  name)))
+    (if aloc				; Assigned?
+	(begin (if *debug?*
+		   (note "assigned -> defined" name))
+	       (table-set! (package-undefined-but-assigneds p) name #f)
+	       (set-location-forward! aloc new name p)))
+    new))
+
+(define (note . rest) (apply signal 'note rest))
+
+(define (get-new-location-non-shadowing p name)
+  (let* ((uloc (table-ref (package-undefineds p) name))
+	 (loc
+	  (if uloc
+	      (begin (if *debug?* (note "undefined -> defined" name uloc))
+		     (table-set! (package-undefineds p) name #f)
+		     uloc)
+	      (make-new-location p name))))
+    (if (and (not uloc)
+	     (symbol? name))	; interfaces can't handle generated names
+	(let recur ((q p))
+	  (let loop ((opens (package-opens q)))
+	    (if (not (null? opens))
+		(if (interface-ref (structure-interface (car opens)) name)
+		    ;; Shadowing
+		    (let* ((q (structure-package (car opens)))
+			   (probe (table-ref (package-undefineds q)
+					    name)))
+		      (if probe
+			  (begin (if *debug?*
+				     (note "undefined -> shadowed"
+					   name loc probe))
+				 (cope-with-mutation p name loc probe))
+			  (recur q)))
+		    (loop (cdr opens)))))))
+    loc))
+
+; COPE-WITH-MUTATION:
+; A package system mutation has newly caused NAME to be bound in
+; package P to NEW, but prior references assumed that its binding was
+; PREV (perhaps inherited from another package).  If PREV is a
+; location, then each occurrence of it stowed away in templates and
+; packages must eventually be replaced by either location NEW, if P's
+; binding is the one that's visible at that occurrence, or to a fresh
+; location to replace PREV, if not.
+
+(define (cope-with-mutation p name new prev)
+  (if (eq? new prev)
+      (error "lossage in cope-with-mutation" p name new prev))
+  (let ((replacement (make-new-location p name)))
+    (copy-location-info! prev replacement)
+    (table-set! (package-cached p) name new)
+    (if *debug?*
+	(begin (write `(mutation ,prev ,new ,replacement)) (newline)))
+    (shadow-location! prev
+		      (map package-uid
+			   (packages-seeing-location p name prev))
+		      new
+		      replacement)))
+
+;(define (set-binding-place! b foo) (vector-set! b 1 foo))
+
+
+; Hmm.  It ought to be possible to turn this into an RPC.
+
+(define (copy-shadowed-contents! import loc)
+  (if (location-defined? import)
+      (set-contents! loc (contents import))))
+
+
+; Return a list of all packages that might have cached a particular
+; inherited binding.
+
+(define (packages-seeing-location package name loc)
+  (if (not (symbol? name)) ; interfaces cannot handle generated names
+      (list package)
+      (let ((losers '())) ; was (list package) but that disables the
+	                  ; entire procedure
+	(let recur ((package package))
+	  (if (and (not (memq package losers))
+		   (not (table-ref (package-definitions package) name)))
+	      (begin (set! losers (cons package losers))
+		     (walk-population
+		      (lambda (struct)
+			(if (interface-ref (structure-interface struct) name)
+			    (walk-population recur (structure-clients struct))))
+		      (package-clients package)))))
+	losers)))
+
+(define (set-location-forward! loser new name p)
+  (if *debug?*
+      (begin (write `(forward ,loser ,new)) (newline)))
+  (for-each (lambda (q)
+	      (package-note-caching! q name new))
+	    (packages-seeing-location p name loser))
+  (shadow-location! loser '() #f new))
+
+
+(set-fluid! $get-location get-new-location-carefully)  ;foo
+
+
+(define (copy-location-info! from to)
+  (let ((probe (location-info from)))
+    (if probe
+        (table-set! location-info-table (location-id to) probe))))
+
+
+;; Deal with editing operations
+
+(define (really-verify-later! thunk)           ;cf. define-structure macro
+  (let ((loser (ignore-errors thunk)))
+    (cond ((or (structure? loser)
+               (interface? loser))
+	   ;; (write `(loser: ,loser)) (newline)
+           (set-fluid! $losers (cons loser (fluid $losers))))))
+  #f)
+
+(define $losers (make-fluid '()))
+(define $package-losers (make-fluid '()))
+
+(define (package-system-sentinel)
+  (drain $losers verify-loser)
+  (drain $package-losers verify-package))
+
+(define (verify-loser loser)
+  (if *debug?*
+      (begin (write `(verify-loser ,loser)) (newline)))
+  (cond ((structure? loser)
+	 (reinitialize-structure! loser)
+	 (walk-population
+	  (lambda (p)
+	    (reinitialize-package! p)
+	    (let ((ps (fluid $package-losers)))
+	      (if (not (memq p ps))
+		  (set-fluid! $package-losers
+			      (cons p ps)))))
+	  (structure-clients loser)))
+	((interface? loser)
+	 (walk-population verify-loser (interface-clients loser)))))
+
+(define (drain flu check)
+  (let loop ()
+    (let ((losers (fluid flu)))
+      (if (not (null? losers))
+	  (let ((loser (car losers)))
+	    (set-fluid! flu (cdr losers))
+	    (check loser)
+	    (loop))))))
+
+(define *debug?* #f)
+
+; --------------------
+; If any looked-up location is now invalid, do something about it.  We
+; might have a previously unbound variable that is now exported by
+; some structure; or, we might have a variable that was bound in some
+; structure before, but now either that structure doesn't export it at
+; all, or we're now getting that binding from some new structure.
+
+(define (verify-package p)
+  (verify-package-cached p)
+  (verify-package-undefineds p))
+
+; unbound -> bound
+
+(define (verify-package-undefineds p)
+  (if *debug?*
+      (begin (write `(verify undefineds ,p)) (newline)))
+  (let ((newly-defined '())
+        (defs (package-definitions p))
+        (undefs (package-undefineds p)))
+    (table-walk (lambda (name prev)
+                  (if (table-ref defs name)
+		      (error "lossage in verify-package-undefineds" p name))
+		  (let ((binding (package-lookup p name)))
+		    (if (binding? binding)
+			(let ((place (binding-place binding)))
+			  (if (eq? place prev)
+			      (error "lossage - verify-package-undefineds"
+				     p name binding))
+			  (set-location-forward! prev place name p)
+			  (set! newly-defined
+				(cons name newly-defined)))
+			(let ((loc (location-for-reference p name)))
+			  (if (not (eq? loc prev))
+			      ;; Newly imported
+			      (begin (set-location-forward! prev loc name p)
+				     (set! newly-defined
+					   (cons name newly-defined))))))))
+		undefs)
+    (if (not (null? newly-defined))
+        (begin (display "Newly accessible in ")
+               (write (package-name p))
+               (display ": ")
+               (write newly-defined)
+               (newline)))
+    (for-each (lambda (winner)
+		(table-set! undefs winner #f))
+              newly-defined)))
+
+(define (verify-package-cached p)
+  ;; (write `(verify ,p cached)) (newline)
+  (let ((newly-moved '())
+	(newly-undefined '())
+        (cached (package-cached p)))
+    (table-walk (lambda (name prev)
+                  (let ((binding (package-lookup p name)))
+                    (if (binding? binding)
+			(if (not (eq? (binding-place binding) prev))
+			    (set! newly-moved
+				  (cons name newly-moved)))
+			;; Otherwise either (a) it was previously
+			;; defined but has become newly undefined, or
+			;; (b) it was undefined before and is still, but
+			;; is inherited (or not) from a different place.
+			(let ((u (location-for-reference p name)))
+			  (if (not (eq? u prev))
+			      (set! newly-undefined
+				    (cons name newly-undefined)))))))
+                cached)
+    (if (not (null? newly-moved))
+        (begin (display "Definitions visible in ")
+               (write (package-name p))
+               (display " have moved: ")
+               (write newly-moved)
+               (newline)))
+    (for-each (lambda (name)
+		(let ((new (binding-place (package-lookup p name))))
+		  (cope-with-mutation p name new
+				      (table-ref cached name))
+		  (table-set! cached name new)))
+              newly-moved)
+    (if (and *debug?* (not (null? newly-undefined)))
+	(begin (display "Newly undefined in ")
+               (write (package-name p))
+               (display ": ")
+               (write newly-undefined)
+               (newline)))
+    (for-each (lambda (name)
+		(let ((new (location-for-reference p name)))
+		  (cope-with-mutation p name new
+				      (table-ref cached name))
+		  (table-set! cached name new)))
+	      newly-undefined)))
+
+(set-verify-later! really-verify-later!)
+
+
+;(define (maybe-note-redefinition p name seen new)
+;  (if (and seen (not (compatible? new seen)))
+;      (let ((old-description (binding-description-string seen))
+;            (new-description (binding-description-string new))
+;            (doing (if (package-definition p name)
+;                       "redefining"
+;                       "shadowing")))
+;        (warn (if (equal? old-description new-description)
+;                  doing
+;                  (string-append doing
+;                                 " as "
+;                                 new-description
+;                                 " (prior references assumed "
+;                                 old-description
+;                                 ")"))
+;              name))))
+;
+;; Foo.  This should really set SEEN for all the packages up the
+;; inheritance chain.
+;
+;(define (assume-denotation p name info)
+;  (if (package-unstable? p)    ;***** save space?  and time?
+;      (table-set! (package-seen p) name info))
+;  info)
+;
+;; Little utility for warning messages.
+;
+;(define (binding-description-string d)
+;  (cond ((transform? d)
+;         (if (syntax? d) "macro" "integrated procedure"))
+;        ((operator? d)
+;         (if (syntax? d) "special operator" "primitive procedure"))
+;        (else "variable")))
+
+
+
+(define (package-undefine! p name)
+  (let ((probe (table-ref (package-definitions p) name)))
+    (if probe
+	(begin (table-set! (package-definitions p) name #f)
+	       (set-location-defined?! (binding-place probe) #f)
+	       (set-location-forward!
+		 (binding-place probe)
+		 (let ((new (package-lookup p name)))
+		   (if (binding? new)
+		       (binding-place new)
+		       (location-for-reference p name)))
+		 name p))
+	(warn "can't undefine - binding is inherited"
+	      p name))))
diff --git a/scheme/env/profile.scm b/scheme/env/profile.scm
new file mode 100644
index 0000000..56c5328
--- /dev/null
+++ b/scheme/env/profile.scm
@@ -0,0 +1,173 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Profiling
+
+; NOTE: the sampling rate is set at the beginning of each run.  Different
+; machines and loadings will produce different tick rates.
+
+(define (profile command)
+  (let ((thunk (if (eq? (car command) 'run)
+		   (evaluate `(lambda () ,(cadr command))
+			     (environment-for-commands))
+		   (lambda () (execute-command command)))))
+    (call-with-values
+     (lambda () (run-with-profiling thunk (command-output)))
+     (lambda (results hits running on-stack)
+       (let ((port (command-output)))
+	 (display hits port)
+	 (display " samples" port)
+	 (newline port)
+	 (display "Running:" port)
+	 (newline port)
+	 (display-counts running hits - port)
+	 (display "Waiting:" port)
+	 (newline port)
+	 (display-counts on-stack hits (lambda (total next) next) port)
+	 (set-focus-values! results))))))
+
+(define-command-syntax 'profile "<command>" "profile execution"
+  '(command))
+
+(define (display-counts counts hits combine port)
+  (let ((limit (quotient hits 10)))
+    (do ((counts counts (cdr counts))
+	 (total hits (combine total (cdar counts))))
+	((or (<= total limit)
+	     (null? counts)
+	     (<= (cdar counts) 1)))
+      (display " " port)
+      (display (cdar counts) port)
+      (display " " port)
+      (display (caar counts) port)
+      (newline port))))
+
+; Strategy:
+; Request periodic interrupts.
+; At each interrupt save the current (raw) continuation.
+; Either at the end of the run or every so many interrupts, stop the
+; timer interrupts and walk the continuations adding the templates to
+; a table, with a count of how many times each has been seen.
+
+(define (run-with-profiling thunk port)
+  (calculate-tick-rate! port)
+  (call-with-values
+   (lambda ()
+     (dynamic-wind
+      (lambda ()
+	(vector-set! interrupt-handlers
+		     (enum interrupt alarm)
+		     handle-timer-interrupt)
+	(start-periodic-interrupts!))
+      (lambda ()
+	(primitive-cwcc
+	 (lambda (top)
+	   (set! *top-continuation* (continuation-parent top))
+	   (set! *hits* 0)
+	   (set! *conts* '())
+	   (set! *templates* '())
+	   (set! *template-counts* (make-template-table))
+	   (set! *cont-counts* (make-template-table))
+	   (set! *cont-count* cont-limit)
+	   (thunk))))
+      reset-timer-interrupts!))
+   (lambda results
+     (for-each add-cont-data! *conts*)
+     (let ((templates (gather-template-table-data *template-counts*))
+	   (conts (gather-template-table-data *cont-counts*)))
+       (set! *top-continuation* #f)  ; drop pointer
+       (set! *conts* '())
+       (values results *hits* templates conts)))))
+
+(define *quantum-mantissa* #f)
+(define *quantum-exponent* #f)
+
+; For checking how fast the machine is.
+
+(define (fib x)
+  (if (< x 2)
+      1
+      (+ (fib (- x 1)) (fib (- x 2)))))
+
+(define (calculate-tick-rate! port)
+  (let ((start-time (run-time)))
+    (fib 17)  ; chosen more or less at random.
+    (let ((end-time (run-time)))
+      (set! *quantum-mantissa* (quotient (- end-time start-time) 4))
+      (set! *quantum-exponent* (tick-exponent))
+      (display (round (/ (* *quantum-mantissa* (expt 10 *quantum-exponent*)))) port)
+      (display " ticks per second" port)
+      (newline port))))
+
+(define (start-periodic-interrupts!)
+  (schedule-interrupt *quantum-mantissa* *quantum-exponent* #t))
+
+(define (stop-periodic-interrupts!)
+  (schedule-interrupt 0 0 #f))
+
+(define cont-limit 100)
+
+(define *cont-count* cont-limit)
+
+(define (handle-timer-interrupt template ei)
+  (set! *cont-count* (- *cont-count* 1))
+  (if (= 0 *cont-count*)
+      (begin
+	(stop-periodic-interrupts!)
+	(for-each add-template-data! *templates*)
+	(for-each add-cont-data! *conts*)
+	(set! *cont-count* cont-limit)
+	(set! *templates* '())
+	(set! *conts* '())
+	(start-periodic-interrupts!)))
+  (set! *templates* (cons template *templates*))
+  (set! *hits* (+ *hits* 1))
+  (primitive-cwcc (lambda (cont)
+		    (set! *conts* (cons cont *conts*)))))
+
+(define *top-continuation* #f)
+(define *conts* '())
+(define *templates* '())
+(define *hits* 0)
+
+(define make-template-table (make-table-maker eq? template-id))
+
+(define *template-counts* (make-template-table))
+(define *cont-counts* (make-template-table))
+
+(define (okay-cont? cont)
+  (and cont (not (eq? cont *top-continuation*))))
+
+(define (add-template-data! template)
+  (let ((p (table-ref *template-counts* template)))
+    (if (not p)
+	(table-set! *template-counts*
+		    template
+		    (cons 1 '()))
+	(set-car! p (+ (car p) 1)))))
+
+(define (add-cont-data! cont)
+  (let loop ((cont (continuation-parent cont)))
+    (if (and (okay-cont? cont)
+	     (okay-cont? (continuation-parent cont)))
+	(let* ((template (continuation-template cont))
+	       (p (table-ref *cont-counts* template)))
+	  (if (not p)
+	      (table-set! *cont-counts*
+			  template
+			  (cons 1 '()))
+	      (set-car! p (+ (car p) 1)))
+	  (loop (continuation-parent cont))))))
+
+(define (gather-template-table-data table)
+  (let ((counts '()))
+    (table-walk (lambda (template p)
+		  (set! counts
+			(cons (cons (debug-data-names
+				     (template-debug-data template))
+				    (car p))
+			      counts)))
+		table)
+    (sort-list counts
+	       (lambda (p1 p2)
+		 (>= (cdr p1) (cdr p2))))))
diff --git a/scheme/env/read-command.scm b/scheme/env/read-command.scm
new file mode 100644
index 0000000..6dea3f3
--- /dev/null
+++ b/scheme/env/read-command.scm
@@ -0,0 +1,194 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Read a command.  No command name completion, yet.
+
+(define (read-command prompt form-preferred? i-port)
+  (really-read-command prompt form-preferred? i-port no-more-commands))
+
+(define (really-read-command prompt form-preferred? i-port more-commands)
+  (let ((o-port (command-output)))
+    (let prompt-loop ()
+      (if (and prompt (not (batch-mode?)))
+	  (display prompt o-port))
+      (force-output o-port)		;foo
+      (let loop ()
+        (let ((c (peek-char i-port)))
+          (cond ((eof-object? c)
+                 (read-char i-port))
+                ((char-whitespace? c)
+                 (read-char i-port)
+                 (if (char=? c #\newline)
+                     (prompt-loop)
+                     (loop)))
+                ((char=? c #\;)      ;Comment
+		 (gobble-line i-port)
+		 (prompt-loop))
+                ((char=? c command-prefix)
+                 (read-char i-port)
+                 (read-named-command i-port more-commands form-preferred?))
+		((or form-preferred?
+		     (and (not (char-alphabetic? c))
+			  (not (char-numeric? c))
+			  (not (char=? c #\?))))
+		 (read-evaluation-command i-port))
+		(else
+		 (read-named-command i-port more-commands form-preferred?))))))))
+
+(define (read-command-carefully prompt form-preferred? i-port . more-commands)
+  (call-with-current-continuation
+    (lambda (k)
+      (with-handler
+        (lambda (c punt)
+	  (cond ((batch-mode?)
+		 (punt))
+		((or (read-error? c)
+		     (read-command-error? c))
+		 (let ((port (last (condition-stuff c))))
+		   (if (eq? port i-port)
+		       (eat-until-newline i-port))
+		   (display-condition c (command-output))
+		   (k #f)))
+		((reset-command-input? c)
+		 (k #f))
+		(else
+		 (punt))))
+	(lambda ()
+	  (really-read-command prompt form-preferred? i-port
+			       (if (null? more-commands)
+				   no-more-commands
+				   (car more-commands))))))))
+
+(define (eat-until-newline port)
+  (do ()
+      ((or (not (char-ready? port))
+	   (let ((c (read-char port)))
+	     (or (eof-object? c)
+		 (char=? c #\newline)))))))
+
+(define (read-evaluation-command i-port)
+  (let ((form (read-form i-port)))
+    (if (eq? (skip-over horizontal-space? i-port) #\newline)
+	(read-char i-port))
+    (make-command 'run (list form))))
+
+(define (no-more-commands name)
+  #f)
+
+; Read a single form, allowing ## as a way to refer to last command
+; output.
+
+(define (read-form port)
+  (with-sharp-sharp (make-node (get-operator 'quote)
+			       (list 'quote (focus-object)))
+    (lambda () (read port))))
+
+; Read a command line:  <name> <arg> ... <newline>
+
+(define (read-named-command port more-commands form-preferred?)
+  (let ((c-name (read port)))
+    (let ((syntax (or (more-commands c-name)
+		      (get-command-syntax c-name))))
+      (cond (syntax
+	     (make-command c-name
+			   (read-command-arguments syntax #f port
+						   more-commands
+						   form-preferred?)))
+	    (else
+	     (read-command-arguments '(&rest form) #f port #f #f) ; flush junk
+	     (write-line "Unrecognized command name." (command-output))
+	     #f)))))
+
+(define (read-command-arguments ds opt? port more-commands form-preferred?)
+  (let recur ((ds ds) (opt? opt?))
+    (let ((c (skip-over horizontal-space? port)))
+      (cond ((and (not (null? ds))
+		  (eq? (car ds) '&opt))
+	     (recur (cdr ds) #t))
+	    ((or (eof-object? c)
+		 (char=? c #\newline)
+		 (if (char=? c #\;)    ;Comment
+			     (begin (gobble-line port)
+				    #t)
+			     #f))
+		 (cond ((or (null? ds)
+			    (eq? (car ds) '&rest)
+			    opt?)
+			(read-char port)
+			'())
+		       (else
+			(read-command-error port
+					    "too few command arguments"))))
+	    ((null? ds)
+	     (read-command-error port "too many command arguments"))
+	    ((eq? (car ds) '&rest)
+	     (let ((arg (read-command-argument (cadr ds) port)))
+	       (cons arg (recur ds #f))))
+	    ((eq? (car ds) 'command)	; must be the last argument
+	     (if (not (null? (cdr ds)))
+		 (error "invalid argument descriptions" ds))
+	     (list (really-read-command #f form-preferred? port more-commands)))
+	    (else
+	     (let ((arg (read-command-argument (car ds) port)))
+	       (cons arg (recur (cdr ds) opt?))))))))
+
+(define (read-command-argument d port)
+  (if (procedure? d)
+      (d port)
+      (case d
+	((filename)
+	 (read-string port char-whitespace?))
+	((expression form)
+	 (read-form port))
+	((name)
+	 (let ((thing (read port)))
+	   (if (symbol? thing)
+	       thing
+	       (read-command-error port "invalid name" thing))))
+	(else (error "invalid argument description" d)))))
+
+(define-condition-type 'read-command-error '(error))
+(define read-command-error? (condition-predicate 'read-command-error))
+
+(define (read-command-error port message . rest)
+  (apply signal 'read-command-error message (append rest (list port))))
+
+
+; Utilities.
+
+(define (horizontal-space? c)
+  (and (char-whitespace? c)
+       (not (char=? c #\newline))))
+
+(define (read-string port delimiter?)
+  (let loop ((l '()))
+    (let ((c (peek-char port)))
+      (cond ((or (eof-object? c)
+                 (delimiter? c))
+             (list->string (reverse l)))
+            (else
+             (loop (cons (read-char port) l)))))))
+
+(define (skip-over pred port)
+  (let ((c (peek-char port)))
+    (cond ((eof-object? c) c)
+	  ((pred c) (read-char port) (skip-over pred port))
+	  (else c))))
+
+
+
+; ## should evaluate to the last REP-loop result.
+(define-sharp-macro #\#
+  (lambda (c port)
+    (read-char port)
+    ((fluid $sharp-sharp) port)))
+
+(define $sharp-sharp
+  (make-fluid (lambda (port) (reading-error port "## in invalid context"))))
+
+(define (with-sharp-sharp form body)
+  (let-fluid $sharp-sharp (lambda (port) form) body))
+
+(define make-command cons)      ;(name . args)
+
+; (put 'with-sharp-sharp 'scheme-indent-hook 1)
diff --git a/scheme/env/shadow.scm b/scheme/env/shadow.scm
new file mode 100644
index 0000000..2fcb849
--- /dev/null
+++ b/scheme/env/shadow.scm
@@ -0,0 +1,73 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Deal with shadowed variables.
+
+; When a variable is shadowed by a variable, split the existing shared
+; location into two replacement locations.
+
+; name (structure-ref p name) (define name ...) within a single template
+; will lose big.
+
+;(define *replaced-locations* '()) ;alist of (old rep ((uid ...) . new))
+
+(define (shadow-location! old p-uids new replacement)
+  (if (location-defined? old)
+      (set-contents! replacement (contents old)))
+  (set-location-id! old
+		    (vector replacement p-uids new))
+  (set-location-defined?! old #f))  ;so that exceptions will be raised
+
+(define maybe-replace-location
+  (let ((memv memv))
+    (lambda (loc p-uid)			;Package's unique id
+      (let ((foo (location-id loc)))
+	(if (vector? foo)
+	    (maybe-replace-location
+	     (if (memv p-uid (vector-ref foo 1))
+		 (vector-ref foo 2)
+		 (vector-ref foo 0))
+	     p-uid)
+	    loc)))))
+
+; Exception handler:
+
+(define (deal-with-replaced-variables succeed)
+  (lambda (opcode reason loc . rest)
+    (if (= reason (enum exception undefined-global))
+	(deal-with-replaced-variable opcode reason loc rest succeed)
+	(apply signal-exception opcode reason loc rest))))
+
+(define (deal-with-replaced-variable opcode reason loc rest succeed)
+  (primitive-catch
+   (lambda (cont)
+     (let* ((tem (continuation-template cont))
+	    (index (+ (code-vector-ref (template-code tem)
+				       (+ (continuation-pc cont) 2))
+		      (* (code-vector-ref (template-code tem)
+					  (+ (continuation-pc cont) 1))
+			 byte-limit))))
+       (if (eq? (template-ref tem index) loc)
+	   (let* ((p-uid (do ((env (continuation-env cont)
+				   (vector-ref env 0)))
+			     ((not (vector? env)) env)))
+		  (new (maybe-replace-location loc p-uid)))
+	     (if (eq? new loc)
+		 (apply signal-exception opcode reason loc rest)
+		 (begin (template-set! tem index new)
+			;(signal 'note "Replaced location" loc new p-uid)
+			(if (location-defined? new)
+			    (succeed new rest)
+			    (apply signal-exception opcode reason new rest)))))
+	   (error "lossage in deal-with-replaced-variables"
+		  loc index))))))
+
+(define-exception-handler (enum op global)
+  (deal-with-replaced-variables
+   (lambda (loc more-args)
+     (contents loc))))
+
+(define-exception-handler (enum op set-global!)
+  (deal-with-replaced-variables
+   (lambda (loc more-args)
+     (set-contents! loc (car more-args)))))
diff --git a/scheme/env/space.scm b/scheme/env/space.scm
new file mode 100644
index 0000000..525fa53
--- /dev/null
+++ b/scheme/env/space.scm
@@ -0,0 +1,206 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+
+; ,open architecture primitives assembler packages enumerated 
+; ,open features sort locations display-conditions
+
+(define length-procedures
+  (do ((i (- stob-count 1) (- i 1))
+       (l '() (cons (eval `(lap *length ()
+                                (check-nargs= 1)
+                                (pop)
+                                (stored-object-length
+                                  ,(enumerand->name i stob))
+				(push)
+				(literal '2)
+				(arithmetic-shift)
+                                (return))
+                          (interaction-environment))
+                    l)))
+      ((< i 0) l)))
+
+(define (space)
+  (collect)
+  (display "                     pure          impure        total") (newline)
+  (display "                  count  bytes  count  bytes  count  bytes")
+  (newline)
+  (let loop ((i 0)
+             (p-count-total 0)
+             (p-bytes-total 0)
+             (i-count-total 0)
+             (i-bytes-total 0))
+    (if (< i stob-count)
+        (begin
+          (collect)
+          (let ((xs (find-all i))
+                (length (list-ref length-procedures i)))
+            (let loop2 ((j (- (vector-length xs) 1))
+                        (p-count 0)
+                        (i-count 0)
+                        (p-bytes 0)
+                        (i-bytes 0))
+              (if (< j 0)
+                  (begin (report1 (enumerand->name i stob)
+                                  p-count p-bytes
+                                  i-count i-bytes)
+                         (loop (+ i 1)
+                               (+ p-count-total p-count)
+                               (+ p-bytes-total p-bytes)
+                               (+ i-count-total i-count)
+                               (+ i-bytes-total i-bytes)))
+                  (if (immutable? (vector-ref xs j))
+                      (loop2 (- j 1)
+                             (+ p-count 1)
+                             i-count
+                             (+ p-bytes (+ 4 (length (vector-ref xs j))))
+                             i-bytes)
+                      (loop2 (- j 1)
+                             p-count
+                             (+ i-count 1)
+                             p-bytes
+                             (+ i-bytes (+ 4 (length (vector-ref xs j))))))))))
+        (report1 'total
+                 p-count-total p-bytes-total
+                 i-count-total i-bytes-total))))
+
+(define (report1 name p-count p-bytes i-count i-bytes)
+  (write-padded name 16)
+  (write-padded p-count 7)
+  (write-padded p-bytes 7)
+  (write-padded i-count 7)
+  (write-padded i-bytes 7)
+  (write-padded (+ p-count i-count) 7)
+  (write-padded (+ p-bytes i-bytes) 8)
+  (newline))
+
+(define least-byte-type (enum stob string))
+
+
+(define (write-padded x pad)
+  (let ((s (if (symbol? x)
+               (symbol->string x)
+               (number->string x))))
+    (display (make-string (- pad (string-length s)) #\space))
+    (display s)))
+
+
+(define (record-space . pred-option)
+  (collect)
+  (let ((pred (if (null? pred-option) (lambda (x) #t) (car pred-option)))
+	(rs (find-all (enum stob record)))
+        (a '()))
+    (do ((i (- (vector-length rs) 1) (- i 1)))
+        ((< i 0)
+         (for-each (lambda (z)
+                     (write-padded (cadr z) 7)
+                     (write-padded (* (caddr z) 4) 7)
+                     (display "  ")
+                     (write (car z))
+                     (newline))
+                   (sort-list a (lambda (z1 z2)
+                                  (> (caddr z1) (caddr z2))))))
+      (let* ((r (vector-ref rs i))
+             (probe (assq (record-ref r 0) a)))
+        (if (pred r)
+	    (if probe
+		(begin (set-car! (cdr probe) (+ (cadr probe) 1))
+		       (set-car! (cddr probe) (+ (caddr probe)
+						 (+ 1 (record-length r)))))
+		(set! a (cons (list (record-ref r 0) 1 (+ 1 (record-length r)))
+			      a))))))))
+                       
+
+(define (vector-space . pred-option)
+  (collect)
+  (let ((pred (if (null? pred-option) (lambda (x) #t) (car pred-option)))
+	(vs (find-all (enum stob vector))))
+    (let ((e-count 0)
+          (e-bytes 0)
+          (t-count 0)
+          (t-bytes 0)
+          (b-count 0)
+          (b-bytes 0)
+          (v-count 0)
+          (v-bytes 0)
+          (l-count 0)
+          (l-bytes 0)
+          (o-count 0)
+          (o-bytes 0))
+      (let loop ((i (- (vector-length vs) 1)))
+        (if (< i 0)
+            (let ((fz (lambda (k b what)
+                        (write-padded k 7)
+                        (write-padded b 7)
+                        (display what)
+                        (newline))))
+              (fz t-count t-bytes "  table buckets")
+              (fz e-count e-bytes "  table entries")
+              (fz b-count b-bytes "  bindings")
+              (fz v-count v-bytes "  environment info")
+              (fz l-count l-bytes "  lexical environments")
+              (fz o-count o-bytes "  other"))
+            (let* ((v (vector-ref vs i))
+                   (len (vector-length v))
+                   (bytes (* (+ len 1) 4)))
+              (cond ((not (pred v)))
+                    ((and (= len 3)
+                          (bucket? (vector-ref v 2)))
+                     (set! e-count (+ e-count 1))
+                     (set! e-bytes (+ e-bytes bytes)))
+                    ((and (= len 3)
+                          (location? (vector-ref v 1)))
+                     (set! b-count (+ b-count 1))
+                     (set! b-bytes (+ b-bytes bytes)))
+                    ((vector-every bucket? v)
+                     (set! t-count (+ t-count 1))
+                     (set! t-bytes (+ t-bytes bytes)))
+                    ((or (and (= len 4)
+                              (integer? (vector-ref v 0))
+                              (list? (vector-ref v 3)))
+                         (vector-every symbol? v))
+                     (set! v-count (+ v-count 1))
+                     (set! v-bytes (+ v-bytes bytes)))
+                    ((and (> len 1)
+                          (or (vector? (vector-ref v 0))
+                              (integer? (vector-ref v 0))))
+                     (set! l-count (+ l-count 1))
+                     (set! l-bytes (+ l-bytes bytes)))
+                    (else
+                     ;;(if (= (remainder i 197) 0)
+                     ;;    (begin (write v) (newline)))
+                     (set! o-count (+ o-count 1))
+                     (set! o-bytes (+ o-bytes bytes))))
+              (loop (- i 1))))))))
+
+
+(define (bucket? x)
+  (or (eq? x #f)
+      (vector? x)))
+
+(define (vector-every pred v)
+  (let loop ((i (- (vector-length v) 1)))
+    (if (< i 0)
+        #t
+        (if (pred (vector-ref v i))
+            (loop (- i 1))
+            #f))))
+
+(define (mutable? x) (not (immutable? x)))
+
+
+; Print a random sampling of mutable pairs.
+
+(define (pair-space)
+  (collect)
+  (let ((vs (find-all (enum stob pair))))
+    (let loop ((i (- (vector-length vs) 1))
+	       (j 0))
+      (if (>= i 0)
+	  (let ((x (vector-ref vs i)))
+	  (if (mutable? x)
+	      (begin (if (= (remainder j 293) 0)
+			 (begin (limited-write x (current-output-port) 4 4)
+				(newline)))
+		     (loop (- i 1) (+ j 1)))
+	      (loop (- i 1) j)))))))
diff --git a/scheme/env/start.scm b/scheme/env/start.scm
new file mode 100644
index 0000000..02839df
--- /dev/null
+++ b/scheme/env/start.scm
@@ -0,0 +1,67 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+(define (start structs-to-open)
+  (lambda (structs-thunk)
+    (usual-resumer
+     (lambda (arg)
+       (let* ((structs (structs-thunk))
+	      (b (make-built-in-structures structs)))
+	 (initialize-interaction-environment! b)
+	 (with-interaction-environment
+	     (make-initial-package b structs-to-open)
+	   (lambda ()
+	     (command-processor (cond ((assq 'usual-commands structs)
+				       => (lambda (z)
+					    (structure-package (cdr z))))
+				      (else #f))
+				arg))))))))
+
+; The structs argument is an a-list of (name . structure), as computed
+; by the expression returned by reify-structures.
+
+(define (make-built-in-structures structs)
+  (let* ((p (make-simple-package '() #f #f 'built-in-structures))
+	 (s (make-structure p
+		  (lambda ()
+		    (make-simple-interface
+		       #f			;name
+		       (cons 'built-in-structures (map car structs))))
+		  'built-in-structures)))
+    (for-each (lambda (name+struct)
+		(environment-define! p
+				     (car name+struct)
+				     (cdr name+struct)))
+	      structs)
+    (environment-define! p 'built-in-structures s)
+    s))
+
+(define (initialize-interaction-environment! built-in-structures)
+  (let ((scheme (*structure-ref built-in-structures 'scheme))
+	(tower (make-tower built-in-structures 'interaction)))
+    (set-interaction-environment!
+      (make-simple-package (list scheme) #t tower 'interaction))
+
+    (set-scheme-report-environment!
+      5
+      (make-simple-package (list scheme) #t tower 'r5rs))))
+
+; Intended for bootstrapping the command processor.
+
+(define (make-initial-package built-in-structures structs-to-open)
+  (let ((p (make-simple-package
+	    (cons built-in-structures
+		  (map (lambda (name)
+			 (*structure-ref built-in-structures name))
+		       structs-to-open))
+	    eval
+	    (make-tower built-in-structures 'initial)
+	    'initial)))
+    (environment-define! p 'built-in-structures built-in-structures)
+    p))
+
+(define (make-tower built-in-structures id)
+  (make-reflective-tower eval
+			 (list (*structure-ref built-in-structures
+					       'scheme))
+			 id))
diff --git a/scheme/env/traverse.scm b/scheme/env/traverse.scm
new file mode 100644
index 0000000..9613853
--- /dev/null
+++ b/scheme/env/traverse.scm
@@ -0,0 +1,213 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Utility for tracking down storage leaks.
+;
+; Just do (traverse-depth-first obj1) or (traverse-breadth-first obj1),
+; and then (trail obj2) to find out via what path obj1 points to obj2.
+;
+; Breadth first traversal needs misc/queue.scm.
+
+
+(define *mark-table* #f)
+(define *interesting-table* #f)
+
+(define *traverse-count* 0)
+
+(define (start-over)		
+  (flush-the-symbol-table!)
+  (set! *mark-table* (make-table hash))
+  (set! *interesting-table* (make-table))
+  (set! *traverse-count* 0))
+
+(define (traverse-depth-first obj)
+  (start-over)
+  (let recur ((obj obj) (parent (list 'root)) (parent-tag 'root))
+    (if (stored? obj)
+	(if (not (table-ref *mark-table* obj))
+	    (let ((tag (visit obj parent parent-tag)))
+	      (for-each-subobject (lambda (child)
+				    (recur child obj tag))
+				  obj))))))
+
+(define (traverse-breadth-first obj)
+  (start-over)
+  (let ((queue (make-queue)))
+    (define (deal-with obj parent parent-tag)
+      (if (stored? obj)
+	  (if (not (table-ref *mark-table* obj))
+	      (enqueue! queue
+			(cons obj
+			      (visit obj parent parent-tag))))))
+    (deal-with obj (list 'root) 'root)
+    (let loop ()
+      (if (not (queue-empty? queue))
+	  (let* ((parent+tag (dequeue! queue))
+		 (parent (car parent+tag))
+		 (parent-tag (cdr parent+tag)))
+	    (for-each-subobject (lambda (obj)
+				  (deal-with obj parent parent-tag))
+				parent)
+	    (loop))))))
+
+(define (visit obj parent parent-tag)
+  (table-set! *mark-table* obj parent)
+  (if (interesting? obj)
+      (let ((tag *traverse-count*))
+	(table-set! *interesting-table* tag obj)
+	(set! *traverse-count* (+ *traverse-count* 1))
+	(write tag) (display " ")
+	(write (list parent-tag))
+	(display ": ") (write obj) (newline)
+	tag)
+      parent-tag))
+
+(define (trail obj)
+  (let loop ((obj (if (integer? obj)
+		      (table-ref *interesting-table* obj)
+		      obj)))
+    (let ((probe (table-ref *mark-table* obj)))
+      (if probe
+	  (loop probe))
+      (if (not (vector? obj))
+	  (begin (write obj)
+		 (newline))))))
+
+(define (interesting? obj)
+  (and (closure? obj)
+       (let ((info (template-info (closure-template obj))))
+	 (if (integer? info)
+	     (> info first-interesting-template-info)
+	     #t))))
+
+(define (template-info tem) (template-ref tem 1))
+
+(define first-interesting-template-info
+  (template-info (closure-template read))) ;foo
+  
+;(define (interesting? obj)
+;  (if (pair? obj)
+;      #f
+;      (if (vector? obj)
+;          #f
+;          #t)))
+	  
+(define (for-each-subobject proc obj)
+  (cond ((pair? obj)
+	 (proc (car obj))
+	 (proc (cdr obj)))
+	((symbol? obj)
+	 (proc (symbol->string obj)))
+	((vector? obj)
+	 (vector-for-each proc obj))
+	((closure? obj)
+	 (proc (closure-template obj))
+	 (proc (closure-env obj)))
+	((location? obj)
+	 (proc (location-id obj))
+	 (if (location-defined? obj)
+	     (proc (contents obj))))
+	((record? obj)
+	 (cond ((eq? obj *mark-table*)	;or (debug-data-table)
+		(display "skipping mark table") (newline))
+	       ((eq? obj *interesting-table*)
+		(display "skipping interesting table") (newline))
+	       (else
+		(record-for-each proc obj))))
+	((continuation? obj)
+	 (continuation-for-each proc obj))
+	((template? obj)
+	 (template-for-each proc obj))
+	((extended-number? obj)
+	 (extended-number-for-each proc obj))))
+
+
+(define (vector-for-each proc v)
+  (let ((z (vector-length v)))
+    (do ((i (- z 1) (- i 1)))
+	((< i 0) #f)
+      (if (not (vector-unassigned? v i))
+	  (proc (vector-ref v i))))))
+
+(define-syntax define-for-each
+  (syntax-rules ()
+    ((define-for-each foo-for-each foo-length foo-ref)
+     (define (foo-for-each proc v)
+       (let ((z (foo-length v)))
+	 (do ((i (- z 1) (- i 1)))
+	     ((< i 0) #f)
+	   (proc (foo-ref v i))))))))
+
+(define-for-each record-for-each
+  record-length record-ref)
+(define-for-each continuation-for-each
+  continuation-length continuation-ref)
+(define-for-each template-for-each
+  template-length template-ref)
+(define-for-each extended-number-for-each
+  extended-number-length extended-number-ref)
+
+
+(define (quick-hash obj n)
+  (cond ((symbol? obj) (string-hash (symbol->string obj)))
+	((location? obj) (+ 3 (quick-hash (location-id obj) n)))
+	((string? obj) (+ 33 (string-hash obj)))
+	((integer? obj) (if (and (>= obj 0)
+				 (< obj hash-mask))
+			    obj
+			    (modulo obj hash-mask)))
+	((char? obj) (+ 333 (char->integer obj)))
+	((eq? obj #f) 3001)
+	((eq? obj #t) 3003)
+	((null? obj) 3005)
+	((pair? obj) (if (= n 0)
+			 30007
+			 (+ (quick-hash (car obj) (- n 1))
+			    (quick-hash (cdr obj) (- n 1)))))
+	((vector? obj) (if (= n 0)
+			   30009
+			   (if (> (vector-length obj) 1)
+			       (+ 30011 (quick-hash (vector-ref obj 1)
+						    (- n 1)))
+			       30017)))
+	((number? obj) 4000)
+	((closure? obj) 4004)
+	((template? obj) (if (= n 0)
+			     300013
+			     (+ 30027 (quick-hash (template-ref obj 1)
+						  (- n 1)))))
+	((output-port? obj) 4006)
+	((input-port? obj) 4007)
+	((record? obj) 4008)
+	((continuation? obj) 4009)
+	((number? obj) 40010)
+	((string? obj) 40011)
+	((code-vector? obj) 40012)
+	((eq? obj (unspecific)) 40013)
+	(else 50007)))
+
+(define hash-mask (- (arithmetic-shift 1 26) 1))
+
+(define (hash obj) (quick-hash obj 1))
+
+(define (leaf? obj)
+  (or (and (number? obj)
+	   (not (extended-number? obj)))
+      ;; (symbol? obj)
+      (string? obj)
+      (code-vector? obj)
+      (char? obj)
+      (eq? obj #f)
+      (eq? obj #t)
+      (eq? obj '())
+      (eq? obj (unspecific))))
+
+(define usual-leaf-predicate leaf?)
+
+(define (set-leaf-predicate! proc) (set! leaf? proc))
+
+(define (stored? obj) (not (leaf? obj)))
+
+(define least-fixnum (arithmetic-shift -1 29))
+(define greatest-fixnum (- -1 least-fixnum))
+
diff --git a/scheme/env/version-info.scm b/scheme/env/version-info.scm
new file mode 100644
index 0000000..79416cc
--- /dev/null
+++ b/scheme/env/version-info.scm
@@ -0,0 +1,3 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+(define version-info "0.53")
diff --git a/scheme/infix/packages.scm b/scheme/infix/packages.scm
new file mode 100644
index 0000000..c843e60
--- /dev/null
+++ b/scheme/infix/packages.scm
@@ -0,0 +1,29 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Infix stuff
+
+(define-structure tokenizer (export make-tokenizer-table
+				    set-up-usual-tokenization!
+				    set-char-tokenization!
+				    tokenize)
+  (open scheme records signals defpackage ascii)
+  (access primitives)
+  (files tokenize))
+
+(define-structure pratt (export toplevel-parse
+				parse
+				make-operator
+				make-lexer-table set-char-tokenization!
+				lexer-ttab define-keyword define-punctuation
+				prsmatch comma-operator delim-error erb-error
+				if-operator
+				then-operator else-operator parse-prefix
+				parse-nary parse-infix
+				parse-matchfix end-of-input-operator
+				port->stream)
+  (open scheme records signals tokenizer tables)
+  (files pratt))
+
+(define-structure sgol (export sgol-read sgol-repl)
+  (open scheme signals pratt)
+  (files sgol))
diff --git a/scheme/infix/pratt.scm b/scheme/infix/pratt.scm
new file mode 100644
index 0000000..a50a423
--- /dev/null
+++ b/scheme/infix/pratt.scm
@@ -0,0 +1,308 @@
+; -*- Mode: Scheme; -*-
+;
+; A simple Pratt-Parser for SIOD: 2-FEB-90, George Carrette, GJC@PARADIGM.COM
+; Siod may be obtained by anonymous FTP to world.std.com:pub/gjc.
+;
+; *                      COPYRIGHT (c) 1988-1994 BY                          *
+; *        PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
+; *                         ALL RIGHTS RESERVED                              *
+;
+;Permission to use, copy, modify, distribute and sell this software
+;and its documentation for any purpose and without fee is hereby
+;granted, provided that the above copyright notice appear in all copies
+;and that both that copyright notice and this permission notice appear
+;in supporting documentation, and that the name of Paradigm Associates
+;Inc not be used in advertising or publicity pertaining to distribution
+;of the software without specific, written prior permission.
+;
+;PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
+;ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
+;PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
+;ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+;WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+;ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+;SOFTWARE.
+;
+; Based on a theory of parsing presented in:                       
+;                                                                      
+;  Pratt, Vaughan R., ``Top Down Operator Precedence,''         
+;  ACM Symposium on Principles of Programming Languages         
+;  Boston, MA; October, 1973.                                   
+;                                                                      
+
+; The following terms may be useful in deciphering this code:
+
+; NUD -- NUll left Denotation (op has nothing to its left (prefix))
+; LED -- LEft Denotation      (op has something to left (postfix or infix))
+
+; LBP -- Left Binding Power  (the stickiness to the left)
+; RBP -- Right Binding Power (the stickiness to the right)
+;
+
+; Mods for Scheme 48 by J Rees 6-14-90
+
+; From: <gjc@mitech.com>
+;
+; Now a neat thing that CGOL had was a way of packaging and scoping
+; different parsing contexts. The maclisp implementation was simple,
+; instead of just NUD and LED and other properties there was a list
+; of property indicators. And a lookup operation.
+;
+; One use of the local-context thing, in parsing the C language
+; you can use a different binding-power for ":" depending on
+; what kind of statement you are parsing, a general statement
+; context where ":" means a label, a "switch" or the "if for value
+; " construct of (a > b) > c : d;
+
+
+(define (peek-token stream)
+  (stream 'peek #f))
+
+(define (read-token stream)
+  (stream 'get #f))
+   
+(define (toplevel-parse stream)
+  (if (eq? end-of-input-operator (peek-token stream))
+      (read-token stream)
+      (parse -1 stream)))
+
+
+; A token is either an operator or atomic (number, identifier, etc.)
+
+(define operator-type
+  (make-record-type 'operator
+		    '(name lbp rbp nud led)))
+
+(define make-operator
+  (let ()
+    (define make
+      (record-constructor operator-type '(name lbp rbp nud led)))
+    (define (make-operator name lbp rbp nud led)
+      (make name
+	    (or lbp default-lbp)
+	    (or rbp default-rbp)
+	    (or nud default-nud)
+	    (or led default-led)))
+    make-operator))
+
+(define operator? (record-predicate operator-type))
+
+(define operator-name (record-accessor operator-type 'name))
+(define operator-nud (record-accessor operator-type 'nud))
+(define operator-led (record-accessor operator-type 'led))
+(define operator-lbp (record-accessor operator-type 'lbp))
+(define operator-rbp (record-accessor operator-type 'rbp))
+
+(define (default-nud operator stream)
+  (if (eq? (operator-led operator) default-led)
+      operator
+      (error 'not-a-prefix-operator operator)))
+
+(define (nudcall token stream)
+  (if (operator? token)
+      ((operator-nud token) token stream)
+      token))
+
+(define default-led #f)
+
+;+++ To do: fix this to make juxtaposition work   (f x+y)
+
+(define (ledcall token left stream)
+  ((or (and (operator? token)
+	    (operator-led token))
+       (error 'not-an-infix-operator token))
+   token
+   left
+   stream))
+
+(define default-lbp 200)
+
+(define (lbp token)
+  (if (operator? token)
+      (operator-lbp token)
+      default-lbp))
+
+(define default-rbp 200)
+
+(define (rbp token)
+  (if (operator? token)
+      (operator-rbp token)
+      default-rbp))
+
+(define-record-discloser operator-type
+  (lambda (obj)
+    (list 'operator (operator-name obj))))
+
+; Mumble
+
+(define (delim-error token stream)
+  (error 'invalid-use-of-delimiter token))
+
+(define (erb-error token left stream)
+  (error 'too-many-right-parentheses token))
+
+(define (premterm-err token stream)
+  (error 'premature-termination-of-input token))
+
+; Parse
+
+(define *parse-debug* #f)
+
+(define (parse rbp-level stream)
+  (if *parse-debug* (print `(parse ,rbp-level)))
+  (let parse-loop ((translation (nudcall (read-token stream) stream)))
+    (if (< rbp-level (lbp (peek-token stream)))
+	(parse-loop (ledcall (read-token stream) translation stream))
+      (begin (if *parse-debug* (print translation))
+	     translation))))
+
+(define (print s) (write s) (newline))
+
+(define (parse-prefix operator stream)
+  (list (operator-name operator)
+	(parse (rbp operator) stream)))
+
+(define (parse-infix operator left stream)
+  (list (operator-name operator)
+	left
+	(parse (rbp operator) stream)))
+
+(define (parse-nary operator left stream)
+  (cons (operator-name operator) (cons left (prsnary operator stream))))
+
+(define (prsnary operator stream)
+  (define (loop l)
+    (if (eq? operator (peek-token stream))
+	(begin (read-token stream)
+	       (loop (cons (parse (rbp operator) stream) l)))
+      (reverse l)))
+  (loop (list (parse (rbp operator) stream))))
+
+; Parenthesis matching, with internal commas.
+; Kind of a kludge if you ask me.
+
+(define (parse-matchfix operator stream) ; |x|
+  (cons (operator-name operator)
+	(prsmatch operator stream)))
+
+(define (prsmatch close-op stream)
+  (if (eq? (peek-token stream) close-op)
+      (begin (read-token stream)
+	     '())
+      (let loop ((l (list (parse 10 stream))))
+	(if (eq? (peek-token stream) close-op)
+	    (begin (read-token stream)
+		   (reverse l))
+	    (if (eq? (peek-token stream) comma-operator)
+		(begin (read-token stream)
+		       (loop (cons (parse 10 stream) l)))
+		(error 'comma-or-match-not-found (read-token stream)))))))
+
+(define comma-operator (make-operator 'comma 10 #f delim-error #f))
+
+; if A then B [else C]
+
+(define (if-nud token stream)
+  (let* ((pred (parse (rbp token) stream))
+	 (then (if (eq? (peek-token stream) then-operator)
+		   (parse (rbp (read-token stream)) stream)
+		   (error 'missing-then pred))))
+    (if (eq? (peek-token stream) else-operator)
+	`(if ,pred ,then ,(parse (rbp (read-token stream)) stream))
+	`(if ,pred ,then))))
+
+(define if-operator (make-operator 'if #f 45 if-nud #f))
+(define then-operator (make-operator 'then 5 25 delim-error #f))
+(define else-operator (make-operator 'else 5 25 delim-error #f))
+
+; Lexer support:
+
+(define lexer-type
+  (make-record-type 'lexer '(ttab punctab keytab)))
+
+(define lexer-ttab    (record-accessor lexer-type 'ttab))
+(define lexer-punctab (record-accessor lexer-type 'punctab))
+(define lexer-keytab  (record-accessor lexer-type 'keytab))
+
+(define make-lexer-table
+  (let ((make (record-constructor lexer-type '(ttab punctab keytab))))
+    (lambda ()
+      (let ((ttab (make-tokenizer-table)))
+	(set-up-usual-tokenization! ttab)
+	(make ttab (make-table) (make-table))))))
+
+(define (lex ltab port)
+  (let ((thing (tokenize (lexer-ttab ltab) port)))
+    (cond ((eof-object? thing)
+	   end-of-input-operator)
+	  ((symbol? thing)
+	   (or (table-ref (lexer-keytab ltab) thing)
+	       thing))
+	  (else thing))))
+
+; Keywords
+
+(define (define-keyword ltab name op)
+  (table-set! (lexer-keytab ltab) name op))
+
+; Punctuation
+
+; lexnode = (* operator (table-of char (+ lexnode #f)))  -- discrimination tree
+
+(define (define-punctuation ltab string op)
+  (let ((end (- (string-length string) 1)))
+    (let loop ((i 0)
+	       (table (lexer-punctab ltab)))
+      (let* ((c (string-ref string i))
+	     (lexnode
+	      (or (table-ref table c)
+		  (let ((lexnode
+			 (cons (error-operator (substring string 0 (+ i 1)))
+			       (make-table))))
+		    (table-set! table c lexnode)
+		    (if (= i 0)
+			(set-char-tokenization! (lexer-ttab ltab)
+						c
+						(operator-reader lexnode)
+						#t))
+		    lexnode))))
+	(if (>= i end)
+	    (set-car! lexnode op)
+	    (loop (+ i 1) (cdr lexnode)))))))
+
+(define (operator-reader lexnode)
+  (lambda (c port)
+    (let loop ((lexnode lexnode))
+      (let ((nextc (peek-char port)))
+	(let ((nextnode (table-ref (cdr lexnode) nextc)))
+	  (if nextnode
+	      (begin (read-char port)
+		     (loop nextnode))
+	      (car lexnode)))))))
+
+(define (error-operator string)
+  (make-operator 'invalid-operator #f #f
+		 (lambda rest (error "invalid operator" string))
+		 #f))
+
+; Mumble
+
+(define end-of-input-operator
+  (make-operator "end of input" -1 #f premterm-err #f))
+
+(define (port->stream port ltab)
+  (define (really-get)
+    (lex ltab port))
+  (define peeked? #f)
+  (define peek #f)
+  (define (stream op arg)
+    (case op
+      ((get) (if peeked?
+		 (begin (set! peeked? #f) peek)
+		 (really-get)))
+      ((peek) (if peeked?
+		  peek
+		  (begin (set! peeked? #t)
+			 (set! peek (really-get))
+			 peek)))))
+  stream)
diff --git a/scheme/infix/sgol-runtime.scm b/scheme/infix/sgol-runtime.scm
new file mode 100644
index 0000000..1b99273
--- /dev/null
+++ b/scheme/infix/sgol-runtime.scm
@@ -0,0 +1,11 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+(define (%unspecific)
+  (if #f #f))
+
+(define (!= x y)
+  (not (= x y)))
+
+(define (%tuple . rest)
+  (list->vector (cons 'tuple rest)))
diff --git a/scheme/infix/sgol.scm b/scheme/infix/sgol.scm
new file mode 100644
index 0000000..e47c1bd
--- /dev/null
+++ b/scheme/infix/sgol.scm
@@ -0,0 +1,213 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Lexer for Infix Scheme (JAR's obscure syntax)
+; Bears no relation to Pratt's CGOL
+
+; To do: add ML-ish binding constructs.
+
+;  (sgol-read)  reads an expression
+;
+;  semicolon    terminates input
+;  comment character is # (comment goes to end of line)
+;
+;  f(x, y)  reads as  (f x y)
+;
+;  if x then y else z      reads as  (if x y z)
+;  x and y, x or y, not x  do the obvious thing
+;
+;  x + y    reads as  (+ x y)     - similarly for - * / = < > <= >=
+;
+;  x::y     reads as  (cons x y)     - ML's syntax
+;  x++y     reads as  (append x y)   - whose syntax?  Haskell's?
+;  []            reads as  '()
+;  [a, b, ...]   reads as  (list a b ...)
+;
+;  ()            reads as  the-unit
+;  (x, y, ...)   reads as  (tuple x y ...)
+;
+;  a[i]		 reads as  (vector-ref a i)
+;  a[i, j, ...]  reads as  (array-ref a i j ...)
+;
+;  x := y       reads as  (set! x y)
+;  car(x) := y  reads as  (set-car! x y)       - similarly for cdr
+;  x[y] := z    reads as  (vector-set! x y z)  - similarly for array-ref
+;
+;  'foo'   tries to read as 'foo  but usually loses
+
+
+(define sgol-lexer-table (make-lexer-table))
+
+(set-char-tokenization! (lexer-ttab sgol-lexer-table)
+			#\#
+			(lambda (c port)
+			  c		;ignored
+			  (gobble-line port)
+			  (read port))
+			#t)
+
+(define (gobble-line port)
+  (let loop ()
+    (let ((c (read-char port)))
+      (cond ((eof-object? c) c)
+	    ((char=? c #\newline) #f)
+	    (else (loop))))))
+
+;
+
+(define (define-sgol-keyword name op)
+  (define-keyword sgol-lexer-table name op))
+
+(define (define-sgol-punctuation string op)
+  (define-punctuation sgol-lexer-table string op))
+
+; Arguments to make-operator are: name lbp rbp nud led
+
+(define (open-paren-nud token stream)
+  (let ((right (prsmatch close-paren-operator stream)))
+    (if (null? right)
+	'the-unit			; ()
+	(if (null? (cdr right))
+	    (car right)			; (x)
+	    (cons 'tuple right)))))	; (x, y, ..., z)
+
+; f(x, y) reads as (f x y)
+; f((x, y)) reads as (f (tuple x y))
+
+(define (open-paren-led token left stream)
+  (cons left (prsmatch close-paren-operator stream)))
+
+(define-sgol-punctuation "("
+  (make-operator 'open-paren 200 #f open-paren-nud open-paren-led))
+
+(define-sgol-punctuation "," comma-operator)
+
+(define close-paren-operator
+  (make-operator 'close-paren 5 #f delim-error erb-error))
+(define-sgol-punctuation ")" close-paren-operator)
+
+; Boolean operators
+
+(define-sgol-keyword 'true '#t)
+(define-sgol-keyword 'false '#f)
+
+(define-sgol-keyword 'if if-operator)
+(define-sgol-keyword 'then then-operator)
+(define-sgol-keyword 'else else-operator)
+
+(define-sgol-keyword 'not (make-operator 'not 70 70 parse-prefix #f))
+(define-sgol-keyword 'and (make-operator 'and 65 #f #f parse-nary))
+(define-sgol-keyword 'or  (make-operator 'or  60 #f #f parse-nary))
+
+; Lists
+
+(define (open-bracket-nud token stream)
+  (let ((elements (prsmatch close-bracket-operator stream)))
+    (if (null? elements)
+	`'()
+	`(list ,@elements))))
+
+(define (open-bracket-led token left stream)
+  (let ((subscripts (prsmatch close-bracket-operator stream)))
+    (if (and (not (null? subscripts))
+	     (null? (cdr subscripts)))
+	`(vector-ref ,left ,@subscripts)
+	`(array-ref ,left ,@subscripts))))
+
+(define-sgol-punctuation "["
+  (make-operator 'open-bracket 200 #f open-bracket-nud open-bracket-led))
+
+(define close-bracket-operator
+  (make-operator 'close-bracket 5 #f delim-error erb-error))
+(define-sgol-punctuation "]" close-bracket-operator)
+
+(define-sgol-punctuation "::"
+  (make-operator 'cons 75 74 #f parse-infix))
+
+(define-sgol-punctuation "++"
+  (make-operator 'append 75 74 #f parse-nary))
+
+; Quotation
+
+(define-sgol-punctuation "'"
+  (make-operator 'quote 5 #f parse-matchfix #f)) ;This isn't right
+
+; Arithmetic
+
+(define-sgol-punctuation "+"
+  (make-operator '+ 100 100 parse-prefix parse-infix))
+
+(define-sgol-punctuation "-"
+  (make-operator '- 100 100 parse-prefix parse-infix))
+
+(define-sgol-punctuation "*"
+  (make-operator '* 120 120 #f parse-infix))  ;should be parse-nary
+
+(define-sgol-punctuation "/"
+  (make-operator '/ 120 120 #f parse-infix))
+
+(define-sgol-punctuation "="
+  (make-operator '= 80 80 #f parse-infix))
+
+(define-sgol-punctuation ">"
+  (make-operator '> 80 80 #f parse-infix))
+
+(define-sgol-punctuation "<"
+  (make-operator '< 80 80 #f parse-infix))
+
+(define-sgol-punctuation ">="
+  (make-operator '>= 80 80 #f parse-infix))
+
+(define-sgol-punctuation "<="
+  (make-operator '<= 80 80 #f parse-infix))
+
+(define-sgol-punctuation "!="
+  (make-operator '!= 80 80 #f parse-infix))
+
+; Side effects
+
+(define (:=-led token left stream)
+  (let* ((form (parse-infix token left stream))
+	 (lhs (cadr form))
+	 (rhs (caddr form)))
+    (if (pair? lhs)
+	(case (car lhs)
+	  ((car) `(set-car! ,@(cdr lhs) ,rhs))
+	  ((cdr) `(set-cdr! ,@(cdr lhs) ,rhs))
+	  ((vector-ref) `(vector-set! ,@(cdr lhs) ,rhs))
+	  ((array-ref) `(array-set! ,@(cdr lhs) ,rhs))
+	  (else (error "invalid LHS for :=" form)))
+	form)))
+
+(define-sgol-punctuation ":="
+  (make-operator 'set! 70 #f #f :=-led))
+
+; End of input...
+
+(define-sgol-punctuation ";" end-of-input-operator)
+
+; Read using Pratt parser with SGOL tokenizer table
+
+(define (sgol-read . port-option)
+  (toplevel-parse (port->stream (if (null? port-option)
+				    (current-input-port)
+				    (car port-option))
+				sgol-lexer-table)))
+
+; Read/print loop
+
+(define (rpl)
+  (let ((thing (sgol-read)))
+    (if (not (eq? thing end-of-input-operator))
+	(begin (write thing)
+	       (newline)
+	       (rpl)))))
+
+; Read/eval/print loop
+
+(define (rpl)
+  (let ((thing (sgol-read)))
+    (if (not (eq? thing end-of-input-operator))
+	(begin (write thing)
+	       (newline)
+	       (rpl)))))
diff --git a/scheme/infix/tokenize.scm b/scheme/infix/tokenize.scm
new file mode 100644
index 0000000..1756a6c
--- /dev/null
+++ b/scheme/infix/tokenize.scm
@@ -0,0 +1,154 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; A tokenizer.
+
+; Nonstandard things needed:
+;  record package
+;  char->ascii
+;  peek-char
+;  reverse-list->string
+;  error
+
+(define (reverse-list->string l n)
+  (list->string (reverse l)))
+
+; Tokenizer tables
+
+(define tokenizer-table-type
+  (make-record-type 'tokenizer-table
+		    '(translation dispatch-vector terminating?-vector)))
+
+(define make-tokenizer-table
+  (let ()
+    (define make
+      (record-constructor tokenizer-table-type
+			  '(translation dispatch-vector terminating?-vector)))
+    (define (make-tokenizer-table)
+      (make (if (char=? (string-ref (symbol->string 't) 0) #\T)
+		char-upcase
+		char-downcase)
+	    (make-vector 256 (lambda (c port)
+			       (error "illegal character read" c)))
+	    (make-vector 256 #t)))
+    make-tokenizer-table))
+
+(define ttab-translation
+  (record-accessor tokenizer-table-type 'translation))
+(define ttab-dispatch-vector
+  (record-accessor tokenizer-table-type 'dispatch-vector))
+(define ttab-terminating?-vector
+  (record-accessor tokenizer-table-type 'terminating?-vector))
+
+(define set-tokenizer-table-translator!
+  (record-modifier tokenizer-table-type 'translation))
+
+(define (set-char-tokenization! ttab char reader term?)
+  (vector-set! (ttab-dispatch-vector ttab) (char->ascii char) reader)
+  (vector-set! (ttab-terminating?-vector ttab) (char->ascii char) term?))
+
+; Main dispatch
+
+(define (tokenize ttab port)
+  (let ((c (read-char port)))
+    (if (eof-object? c)
+        c
+        ((vector-ref (ttab-dispatch-vector ttab) (char->ascii c))
+         c port))))
+
+; Atoms (symbols and numbers)
+
+(define (scan-atom c ttab port)
+  (let ((translate (ttab-translation ttab)))
+    (let loop ((l (list (translate c))) (n 1))
+      (let ((c (peek-char port)))
+	(cond ((or (eof-object? c)
+		   (vector-ref (ttab-terminating?-vector ttab)
+			       (char->ascii c)))
+	       (reverse-list->string l n))
+	      (else
+	       (loop (cons (translate (read-char port)) l)
+		     (+ n 1))))))))
+
+; Allow ->foo, -v-, etc.
+
+(define (parse-atom string)
+  (let ((c (string-ref string 0)))
+    (cond ((char=? c #\+)
+	   (parse-possible-number string))
+          ((char=? c #\-)
+	   (parse-possible-number string))
+          ((char=? c #\.)
+	   (parse-possible-number string))
+          (else
+           (if (char-numeric? c)
+               (parse-number string)
+               (string->symbol string))))))
+
+; First char is + - .
+
+(define (parse-possible-number string)
+  (if (and (> (string-length string) 1)
+	   (char-numeric? (string-ref string 1)))
+      (parse-number string)
+      (string->symbol string)))
+
+(define (parse-number string)
+  (or (string->number string 'e 'd)
+      (error "unsupported number syntax" string)))
+
+
+; Usual stuff (what you'd expect to be common to Scheme and ML syntax)
+
+(define (set-up-usual-tokenization! ttab)
+
+  (define (tokenize-whitespace c port)     c ;ignored
+    (tokenize ttab port))
+
+  (define (tokenize-constituent c port)
+    (parse-atom (scan-atom c ttab port)))
+
+  (for-each (lambda (c)
+	      (set-char-tokenization! ttab (ascii->char c)
+				      tokenize-whitespace #t))
+	    ascii-whitespaces)
+
+  (for-each (lambda (c)
+	      (set-char-tokenization! ttab c tokenize-constituent #f))
+	    (string->list
+	     (string-append ".0123456789"
+			    "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+			    "abcdefghijklmnopqrstuvwxyz")))
+  
+  (set-char-tokenization! ttab #\" tokenize-string #t)
+
+  )
+
+(define (make-constituent! c ttab)
+  (set-char-tokenization! ttab c
+			  (lambda (c port)
+			    (parse-atom (scan-atom c ttab port)))
+			  #f))
+
+(define (tokenize-string c port)      c ;ignored
+  (let loop ((l '()) (i 0))
+    (let ((c (read-char port)))
+      (cond ((eof-object? c)
+	     (error "end of file within a string"))
+	    ((char=? c #\\)
+	     (let ((c (read-char port)))
+	       (if (or (char=? c #\\) (char=? c #\"))
+		   (loop (cons c l) (+ i 1))
+		   (error "invalid escaped character in string" c))))
+	    ((char=? c #\") (reverse-list->string l i))
+	    (else (loop (cons c l) (+ i 1)))))))
+
+; Auxiliary for parse-atom and tokenize-string
+
+;(define (reverse-list->string l n)   ;In microcode?
+;  (let ((s (make-string n)))
+;    (do ((l l (cdr l))
+;        (i (- n 1) (- i 1)))
+;       ((< i 0) s)
+;      (string-set! s i (car l)))))
diff --git a/scheme/initial-packages.scm b/scheme/initial-packages.scm
new file mode 100644
index 0000000..01bc6a6
--- /dev/null
+++ b/scheme/initial-packages.scm
@@ -0,0 +1,105 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Packages involved in building the initial system.
+
+
+; Access to values from packages and structures 
+
+(define-structure environments environments-interface
+  (open scheme-level-2
+	packages bindings meta-types
+	fluids
+	locations	; contents location-assigned?
+	signals)	; error
+  (files (rts env)))
+
+; EVAL and LOAD
+
+(define-structure evaluation evaluation-interface
+  (open scheme-level-2
+	packages        	;package-uid package->environment link!
+	environments		;package-for-load
+	compiler-envs		;bind-source-filename
+	reading-forms		;read-forms $note-file-package
+	syntactic		;scan-forms expand-forms
+	compiler		;compile-forms
+	closures		;make-closure
+	vm-exposure		;invoke-closure
+	features		;current-noise-port force-output
+	signals fluids)
+  (files (rts eval)))
+
+; Scheme = scheme-level-2 plus EVAL and friends
+
+(define-module (make-scheme environments evaluation)
+  (define-structure scheme scheme-interface
+    (open scheme-level-2
+	  environments
+	  evaluation))
+  scheme)
+
+
+; Command processor.
+
+(define-module (make-mini-command scheme) ;copied from debug-packages.scm
+  (define-structure mini-command (export command-processor)
+    (open scheme
+	  signals conditions handle
+	  display-conditions
+	  i/o)                 ;current-error-port
+    (files (debug mini-command)))
+  mini-command)
+
+
+; For building systems.
+
+(define-module (make-initial-system scheme command)
+
+  (define-structure initial-system (export start)
+    (open scheme
+	  command
+	  interfaces		;make-simple-interface
+	  packages		;make-simple-package
+	  environments		;with-interaction-environment, etc.
+	  usual-resumer
+	  conditions handle	;error? with-handler
+	  signals)		;error
+    (files (env start)))
+
+  initial-system)
+
+
+; Utility to load packages following dependency links (OPEN and ACCESS)
+;Cf. (link-initial-system) and Makefile
+
+(define-structure ensures-loaded (export ensure-loaded)
+  (open scheme-level-2
+	features		;current-noise-port
+	packages		;package-uid package-clients
+	packages-internal	;package-loaded? set-package-loaded?!
+	scan-package		;collect-packages check-structure
+	compile-packages	;compile-package
+	closures		;make-closure
+	vm-exposure		;invoke-closure
+	environments		;with-interaction-environment
+	weak			;walk-population
+	)
+  (files (env load-package)))
+
+; Things needed by the expression generated by REIFY-STRUCTURES.
+
+(define-structure for-reification for-reification-interface
+  (open scheme-level-1
+	packages packages-internal
+	signals
+	meta-types			;sexp->type structure-type
+	interfaces			;make-simple-interface
+	bindings
+	nodes				;get-operator operator? operator-type
+	primops				;get-primop primop? primop-type
+	usual-macros			;usual-transform
+	inline				;inline-transform
+	transforms			;make-transform transform? transform-type
+	tables)
+  (files (bcomp for-reify)))
diff --git a/scheme/interfaces.scm b/scheme/interfaces.scm
new file mode 100644
index 0000000..321357b
--- /dev/null
+++ b/scheme/interfaces.scm
@@ -0,0 +1,1185 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Some interfaces.  Order of presentation is a bit random.
+
+(define-interface scheme-level-0-interface
+  (export ((if begin lambda letrec quote set!
+	       define define-syntax let-syntax letrec-syntax)
+	   :syntax)
+	  
+	  ;; The basic derived expression types.
+	  ((and cond do let let* or) :syntax)
+
+	  apply
+
+	  ;; Scalar primitives
+	  eq?
+	  number? integer? rational? real? complex?
+	  exact? exact->inexact inexact->exact
+	  + - * / = < > <= >=
+	  quotient remainder
+	  floor numerator denominator
+	  real-part imag-part
+	  exp log sin cos tan asin acos atan sqrt
+	  angle magnitude make-polar make-rectangular
+	  char?
+	  char=? char<?
+	  eof-object?
+	  input-port? output-port?
+
+	  ;; Data manipulation
+	  pair? cons car cdr set-car! set-cdr!
+	  symbol? symbol->string
+	  string? make-string string-length string-ref string-set!
+	  vector? make-vector vector-length vector-ref vector-set!
+
+	  ;; Unnecessarily primitive
+	  read-char peek-char write-char
+	  string=?
+	  vector
+	  assq
+
+	  ;; New in Revised^5 Scheme
+	  values call-with-values
+
+	  ;; Things aren't primitive at the VM level, but they have
+	  ;; to be defined using VM primitives.
+	  string-copy
+	  string->symbol
+	  procedure?
+	  integer->char char->integer))
+
+; Miscellaneous primitives.
+
+(define-interface primitives-interface
+  (export add-finalizer!
+	  call-external-value
+	  checked-record-ref
+	  checked-record-set!
+	  collect			;,collect command
+	  continuation-length
+	  continuation-ref
+	  continuation-set!
+	  continuation?
+	  copy-bytes!
+	  current-thread		;fluids threads
+	  double?
+	  eof-object                    ;i/o-internal re-exports this
+	  extended-number-length
+	  extended-number-ref
+	  extended-number-set!
+	  extended-number?
+	  find-all			;externals, command-levels
+	  find-all-records		;threads
+	  immutable?
+	  make-continuation
+	  make-double
+	  make-extended-number
+	  make-immutable!
+	  make-record
+	  make-template
+	  make-weak-pointer
+	  memory-status			;interrupts
+	  record
+	  record-length
+	  record-ref
+	  record-set!
+	  record?
+	  return-from-callback
+	  schedule-interrupt            ;interrupts re-exports this
+	  session-data			;channels
+	  set-current-thread!		;fluids threads
+	  set-enabled-interrupts!	;interrupts
+	  set-exception-handlers!
+	  set-interrupt-handlers!	;interrupts
+	  set-session-data!		;channels
+	  string-hash
+	  template-length
+	  template-ref
+	  template-set!
+	  template?
+	  time
+	  unspecific			;record
+	  vm-extension
+	  wait
+	  weak-pointer-ref
+	  weak-pointer?))
+
+(define-interface bitwise-interface
+  (export arithmetic-shift
+	  bitwise-not
+	  ((bitwise-and bitwise-ior bitwise-xor)
+	   (proc (&rest :exact-integer) :exact-integer))))
+
+(define-interface locations-interface
+  (export location?
+	  location-defined?
+	  location-assigned?
+	  location-id
+	  set-location-id!
+	  make-undefined-location
+	  set-location-defined?!
+	  contents
+	  set-contents!))
+
+(define-interface closures-interface
+  (export closure?
+	  make-closure
+	  closure-env
+	  closure-template))
+
+(define-interface byte-vectors-interface
+  (export byte-vector?
+	  byte-vector-length
+	  byte-vector-ref
+	  byte-vector-set!
+	  make-byte-vector))
+
+; Same again, but with old names for compatibility.
+
+(define-interface code-vectors-interface
+  (export code-vector?
+	  code-vector-length
+	  code-vector-ref
+	  code-vector-set!
+	  make-code-vector))
+
+(define-interface channels-interface
+  (export input-channel?
+	  open-input-channel
+	  channel-read	  
+	  close-input-channel
+	  
+	  output-channel?
+	  open-output-channel
+	  channel-write
+	  close-output-channel))
+
+(define-interface low-channels-interface
+  (export channel?
+	  channel-id
+	  channel-status
+	  channel-os-index
+	
+	  open-channel
+	  close-channel
+	  channel-read
+	  channel-write
+	  channel-abort
+
+	  open-channels-list))
+
+(define-interface channels-interface
+  (export input-channel?
+	  open-input-channel
+	  channel-read	  
+	  close-input-channel
+	  
+	  output-channel?
+	  open-output-channel
+	  channel-write
+	  close-output-channel))
+
+(define-interface ports-interface
+  (export port?
+	  make-port
+	  port-handler
+	  port-lock set-port-lock!
+	  port-locked? set-port-locked?!
+	  port-status set-port-status!
+	  port-data set-port-data!
+	  port-buffer set-port-buffer!
+	  port-index set-port-index!
+	  port-limit set-port-limit!
+	  port-pending-eof? set-port-pending-eof?!))
+
+(define-interface locks-interface
+  (export lock?
+	  make-lock
+	  obtain-lock
+	  maybe-obtain-lock
+	  release-lock
+	  lock-owner-uid))    ;really should be internal
+
+(define-interface shared-bindings-interface
+  (export shared-binding?
+	  shared-binding-is-import?
+	  shared-binding-name
+	  shared-binding-ref
+	  shared-binding-set!	  
+	  lookup-imported-binding
+	  define-imported-binding
+	  undefine-imported-binding
+	  lookup-exported-binding
+	  define-exported-binding
+	  undefine-exported-binding))
+
+; Miscellaneous useful procedures used in various random places.
+; These are used in the byte-code compiler and the linker and so have
+; alternative implementations in alt/...
+
+(define-interface features-interface
+  (export immutable?
+	  make-immutable!
+	  string-hash
+	  force-output
+	  current-noise-port))
+
+; Another hodge-podge.
+
+(define-interface low-level-interface
+  (export vector-unassigned?))		;inspector
+
+(define-interface vm-exposure-interface
+  (export invoke-closure		;eval
+	  primitive-catch))		;shadowing, start, command
+
+(define-interface escapes-interface
+  (export primitive-cwcc
+	  with-continuation))
+
+(define-interface ascii-interface
+  (export ascii->char
+	  char->ascii
+	  ascii-limit
+	  ascii-whitespaces))
+
+; Level 1: The rest of Scheme except for I/O.
+
+(define-interface scheme-level-1-adds-interface
+  (export ((case delay quasiquote syntax-rules) :syntax)
+	  abs
+	  append  assoc assv	  
+	  boolean?
+	  caaaar caaadr caadar caaddr caaar caadr caar
+	  cadaar cadadr caddar cadddr cadar caddr cadr
+	  cdaaar cdaadr cdadar cdaddr cdaar cdadr cdar
+	  cddaar cddadr cdddar cddddr cddar cdddr cddr
+	  char->integer char-alphabetic?
+	  ceiling
+	  char-ci<=? char-ci<? char-ci=? char-ci>=? char-ci>?
+	  char-downcase char-lower-case? char-numeric?
+	  char-upcase
+	  char-upper-case? char-whitespace? char<=?
+	  char>=? char>?
+	  equal? eqv? even? expt
+	  for-each force
+	  gcd
+	  inexact?
+	  integer->char
+	  lcm length list list->string list->vector
+	  list?				;New in R4RS
+	  list-ref list-tail
+	  map max member memq memv min modulo
+	  negative? not null?
+	  odd?
+	  positive?
+	  procedure?			;from low-level
+	  rationalize
+	  reverse
+	  round 
+	  string string->list string->symbol
+	  string-append
+	  string-ci<=? string-ci<? string-ci=? string-ci>=? string-ci>?
+	  string-copy			;from low-level
+	  string-fill!
+	  string<=? string<? string=? string>=? string>?
+	  substring
+	  truncate
+	  vector->list vector-fill!
+	  zero?))
+
+(define-interface scheme-level-1-interface
+  (compound-interface scheme-level-1-adds-interface
+		      scheme-level-0-interface))
+
+(define-interface util-interface
+  (export any
+	  every
+	  filter
+	  fold fold->2 fold->3
+	  last
+	  posq
+	  posv
+	  position
+	  reduce
+	  sublist
+	  insert
+	  unspecific))
+
+; Level 2 consists of harder things built on level 1.
+
+(define-interface records-interface
+  (export make-record-type
+	  record-constructor
+	  record-accessor
+	  record-modifier
+	  record-predicate
+	  define-record-discloser
+	  define-record-resumer
+	  record-type?
+	  record-type-field-names
+	  record-type-name))
+
+(define-interface records-internal-interface
+  (export record
+	  record?
+	  record-type
+	  record-length
+	  record-ref
+	  record-set!
+	  :record-type
+	  disclose-record
+	  initialize-records!))
+
+(define-interface define-record-types-interface
+  (export (define-record-type :syntax)
+	  define-record-discloser))
+
+(define-interface methods-interface
+  (export (define-generic :syntax)
+	  (define-method :syntax)
+	  (define-simple-type :syntax)
+	  :values
+	  :value
+	  :number
+	  :complex
+	  :real
+	  :rational
+	  :integer
+	  :exact-integer
+	  :boolean
+	  :symbol
+	  :char
+	  :null
+	  :pair
+	  :vector
+	  :string
+	  :procedure
+	  :input-port
+	  :output-port
+	  :eof-object
+	  :record
+	  :record-type
+	  :zero
+	  singleton
+	  disclose &disclose))
+
+(define-interface meta-methods-interface
+  (export type-predicate &type-predicate
+	  type-priority  &type-priority
+	  type-superiors &type-superiors
+	  same-type?	 &same-type?
+	  add-method!	 &add-method!
+	  set-final-method!
+	  make-method-table         ;rts/exception.scm
+	  method-table-get-perform  ;rts/exception.scm
+	  make-simple-type
+	  ;; Hooks for DOODL or other future extension
+	  :simple-type :method-info :method-table :singleton
+	  make-generic
+	  (method-info :syntax)
+	  methods->perform))
+
+(define-interface number-i/o-interface
+  (export number->string &number->string
+	  string->number
+	  really-string->number &really-string->number ;exactness argument
+	  string->integer))
+
+(define-interface fluids-interface
+  (export make-fluid
+	  let-fluid
+	  let-fluids
+	  fluid
+	  set-fluid!))
+
+(define-interface fluids-internal-interface
+  (export initialize-dynamic-state!
+	  current-thread
+	  set-current-thread!
+	  get-dynamic-env		; wind.scm, env/command-level.scm
+	  set-dynamic-env!		; wind.scm
+	  get-dynamic-point		; wind.scm
+	  set-dynamic-point!))		; wind.scm
+
+(define-interface enumerated-interface
+  (export (define-enumeration :syntax)
+	  (enum :syntax)
+	  (enumerand->name :syntax)
+	  (name->enumerand :syntax)))
+
+(define :enumeration :syntax)
+
+(define-interface signals-interface
+  (export error warn syntax-error call-error
+	  signal signal-condition
+	  make-condition))
+
+(define-interface handle-interface
+  (export ignore-errors report-errors-as-warnings with-handler))
+
+(define-interface conditions-interface
+  (export define-condition-type
+	  condition-predicate
+	  condition-stuff condition-type
+	  error? warning? syntax-error? call-error? read-error?
+	  interrupt?
+
+	  ;; Do these belong here?... not really.
+	  exception-arguments
+	  exception-reason
+	  exception-opcode
+	  exception?
+	  make-exception))
+
+(define-interface wind-interface
+  (export call-with-current-continuation
+	  dynamic-wind))
+
+(define-interface i/o-interface
+  (export current-input-port current-output-port
+	  close-output-port close-input-port
+
+	  char-ready?
+	  read-block write-block
+	  newline
+	  input-port-option		;read.scm
+	  output-port-option		;write.scm
+	  write-string			;write.scm
+	  initialize-i/o                ;init.scm
+	  initialize-output-port-list!  ;init.scm
+	  with-current-ports
+	  initialize-i/o-handlers!      ;init.scm
+	  disclose-port
+	  current-error-port
+	  current-noise-port
+	  force-output			;xport.scm
+	  input-port?
+	  output-port?
+	  silently
+	  make-null-output-port))
+
+(define-interface i/o-internal-interface
+  (export make-input-port
+	  make-output-port make-unbuffered-output-port
+	  make-port-handler
+	  port-handler-buffer-proc     ; extended-ports
+	  default-buffer-size
+
+	  open-input-port?
+	  open-input-port-status
+	  make-input-port-closed!
+	  open-output-port?
+	  open-output-port-status
+	  make-output-port-closed!
+
+	  eof-object                   ; users will probably want this
+
+	  obtain-port-lock
+	  release-port-lock
+
+	  periodically-force-output!
+	  periodically-flushed-ports
+	  force-output-if-open
+	  really-force-output          ; assumes port alread locked
+
+	  output-port-forcers	       ;root-scheduler.scm
+
+	  call-with-current-input-port
+	  call-with-current-output-port
+	  call-with-current-noise-port))
+
+(define-interface channel-i/o-interface
+  (export call-with-input-file call-with-output-file
+	  with-input-from-file with-output-to-file
+	  open-input-file open-output-file
+
+	  initialize-channel-i/o!       ;scheduler
+	  waiting-for-i/o?              ;scheduler
+
+	  steal-channel-port!		;command
+	  
+	  input-channel->port           ;usual-resumer posix
+	  output-channel->port          ;usual-resumer posix
+
+	  input-channel+closer->port    ;big/socket.scm
+	  output-channel+closer->port	;big/socket.scm
+	  
+	  ; call WAIT-FOR-CHANNEL with interrupts disabled
+	  wait-for-channel		;big/socket.scm
+
+	  port->channel			;posix
+	  force-channel-output-ports!	;posix
+	  ))
+
+(define-interface threads-interface
+  (export thread?
+	  thread-name thread-uid        ;for debugging
+
+	  spawn
+	  relinquish-timeslice
+	  sleep
+	  terminate-current-thread))
+
+(define-interface threads-internal-interface
+  (export make-thread
+	  thread-data set-thread-data!
+	  thread-continuation           ;debugger
+	  thread-uid->thread            ;expensive!
+	  thread-scheduler set-thread-scheduler!
+	  set-thread-arguments!
+
+	  current-thread
+
+	  make-thread-queue
+	  thread-queue-empty?
+	  enqueue-thread!
+	  dequeue-thread!
+	  remove-thread-from-queue!
+
+	  event-pending?
+	  get-next-event!
+	  schedule-event
+	  (event-type :syntax)
+
+	  run
+	  running?
+	  
+	  block
+	  make-ready
+	  spawn-on-scheduler spawn-on-root
+	  wait
+	  upcall propogate-upcall
+	  interrupt-thread
+	  kill-thread!
+
+	  wake-some-threads
+
+	  all-threads                   ; for command-levels
+
+	  with-threads))		; rts/init.scm
+
+(define-interface scheduler-interface
+  (export run-threads
+	  run-threads-with-housekeeper
+	  round-robin-event-handler
+
+	  make-counter            ; for thread counts
+	  counter-value
+          increment-counter!
+          decrement-counter!))
+
+(define-interface queues-interface
+  (export make-queue enqueue! dequeue! queue-empty?
+	  queue? queue->list queue-length delete-from-queue!))
+
+(define-interface exceptions-interface
+  (export define-exception-handler
+	  initialize-exceptions!
+	  extend-opcode!
+	  signal-exception
+	  continuation-preview))	;env/debug.scm
+
+(define-interface interrupts-interface
+  (export initialize-interrupts!	;init.scm
+	  all-interrupts
+	  no-interrupts
+	  ;reset-timer-interrupts!
+	  set-interrupt-handler!
+	  interrupt?
+	  ;set-timer-interrupt!
+	  schedule-interrupt
+	  set-enabled-interrupts!	;command.scm
+	  enabled-interrupts
+	  enable-interrupts!
+	  disable-interrupts!
+	  with-interrupts-allowed
+	  with-interrupts-inhibited
+	  call-after-gc!
+	  call-before-heap-overflow!
+	  (interrupt :syntax)))
+
+(define-interface writing-interface
+  (export write
+	  display
+	  display-type-name
+	  recurring-write))
+
+(define-interface reading-interface
+  (export read
+	  define-sharp-macro		;command.scm
+	  reading-error
+	  gobble-line))
+
+; Level 2: the harder stuff.
+; Various primitives get numeric types and promoted to n-ary at this point.
+
+(define-interface scheme-level-2-adds-interface
+  (export (char-ready? (proc (&opt :input-port) :boolean))
+	  call-with-current-continuation
+	  call-with-input-file call-with-output-file
+	  current-input-port current-output-port
+	  dynamic-wind			;New in R5RS
+	  close-input-port close-output-port
+	  open-input-file open-output-file
+	  with-input-from-file with-output-to-file
+	  number->string string->number
+	  newline display write
+	  read))
+
+(define-interface scheme-level-2-interface
+  (compound-interface scheme-level-2-adds-interface
+		      scheme-level-1-interface))
+
+(define-interface scheme-adds-interface
+  (export eval load
+	  interaction-environment
+	  scheme-report-environment
+	  null-environment))
+
+(define-interface scheme-interface
+  (compound-interface scheme-adds-interface
+		      scheme-level-2-interface))
+
+(define-interface continuations-interface
+  (export continuation-arg
+	  continuation-arg-count
+	  continuation-cont
+	  continuation-env
+	  continuation-pc
+	  continuation-template
+	  continuation-parent
+	  continuation?
+	  :continuation
+
+	  exception-continuation?
+	  exception-continuation-exception))
+
+(define-interface templates-interface
+  (export make-template
+	  template-code
+	  template-info
+	  template-length
+	  template-ref
+	  template-overhead
+	  set-template-code!
+	  set-template-info!
+	  template-set!
+	  template?))
+
+(define-interface weak-interface
+  (export weak-pointer?			;disclosers.scm
+	  weak-pointer-ref
+	  make-weak-pointer
+	  make-population
+	  add-to-population!
+	  population->list
+	  walk-population))
+
+(define-interface filenames-interface
+  (export namestring *scheme-file-type* *load-file-type*
+	  file-name-directory
+	  file-name-nondirectory
+	  translate
+	  set-translation!
+	  translations))
+
+
+; Things for the compiler.
+
+(define-interface general-tables-interface
+  (export make-table
+	  make-string-table
+	  make-symbol-table
+	  make-integer-table
+	  make-table-maker
+	  table?
+	  table-ref
+	  table-set!
+	  table-walk
+	  make-table-immutable!
+
+	  string-hash
+	  default-table-hash-function))
+
+;----------------
+; Beginning of compiler interfaces
+
+(define-interface usual-macros-interface
+  (export usual-transform))
+
+(define-interface meta-types-interface
+  (export same-type?
+	  subtype?
+	  meet?
+	  join-type
+	  meet-type
+	  sexp->type type->sexp rail-type->sexp
+	  syntax-type
+	  any-values-type
+	  any-arguments-type
+	  value-type
+	  error-type
+
+	  make-some-values-type
+
+	  empty-rail-type
+	  rail-type
+	  make-optional-type
+	  make-rest-type
+	  empty-rail-type?
+	  rest-type?
+	  head-type
+	  tail-type
+
+	  procedure-type
+	  procedure-type-domain
+	  procedure-type-codomain
+	  restrictive?
+	  procedure-type?
+	  fixed-arity-procedure-type?
+	  procedure-type-argument-types
+	  procedure-type-arity
+	  any-procedure-type
+	  (proc :syntax)
+
+	  boolean-type
+	  char-type
+	  null-type
+	  unspecific-type
+
+	  exact-integer-type
+	  integer-type
+	  rational-type
+	  real-type
+	  complex-type
+	  number-type
+	  exact-type
+	  inexact-type
+
+	  pair-type
+	  string-type
+	  symbol-type
+	  vector-type
+
+	  escape-type
+	  structure-type
+
+	  ;; Stuff moved back from syntactic - why was it moved there?
+	  variable-type
+	  variable-type?
+	  variable-value-type
+	  usual-variable-type
+	  undeclared-type
+
+	  compatible-types?))
+
+(define-interface names-interface
+  (export name?
+	  name->symbol
+
+	  make-name-generator
+	  generate-name		;qualified->name in opt/inline.scm
+	  generated?
+
+	  generated-symbol
+	  generated-token
+	  generated-env
+	  generated-parent-name
+	  generated-uid
+
+	  make-name-table
+
+	  qualified?
+	  qualified-parent-name
+	  qualified-symbol
+	  name->qualified
+
+          desyntaxify
+	  ))
+
+(define-interface transforms-interface
+  (export make-transform
+	  maybe-apply-macro-transform
+	  apply-inline-transform
+	  transform?
+	  transform-type
+
+	  transform-env		; These are used to reify transforms.
+	  transform-aux-names
+	  transform-source
+	  transform-id))
+
+(define-interface bindings-interface
+  (export binding?
+	  make-binding
+	  binding-place
+	  set-binding-place!	;for package mutation, used in package.scm
+	  binding-static
+	  binding-type
+	  binding-path
+
+	  add-path
+	  clobber-binding!
+	  maybe-fix-place!
+	  forget-integration
+	  impose-type
+
+	  same-denotation?
+	  ))
+	  
+;----------------
+; Syntactic interfaces
+
+(define-interface compiler-envs-interface
+  (export make-compiler-env	; re-exported by syntactic
+	  lookup
+	  bind1 bind bindrec
+
+	  bind-source-file-name	; re-exported by syntactic
+	  source-file-name
+
+	  environment-macro-eval
+	  environment-define!
+
+	  extract-package-from-environment))	; temporary
+
+(define-interface syntactic-interface
+  (export expand
+	  expand-form
+	  scan-forms
+	  expand-scanned-form
+	  syntax?
+	  make-compiler-env
+	  bind-source-file-name))
+
+(define-interface nodes-interface
+  (export make-node
+
+	  node?
+	  node-operator
+	  node-operator-id
+	  node-form
+	  node-ref
+	  node-set!
+	  node-predicate
+
+	  make-similar-node
+	  force-node
+	  schemify
+
+	  get-operator
+	  make-operator-table
+	  operator-name
+	  operator-nargs
+	  operator-table-ref
+	  operator-define!
+	  operator-lookup
+	  operator-type
+	  operator-uid
+	  operator?
+	  operators-table		;config.scm comp-package.scm
+	  ))
+
+;----------------
+; Compiler interfaces
+
+(define-interface segments-interface
+  (export attach-label
+	  byte-limit two-byte-limit
+	  high-byte low-byte
+	  empty-segment
+	  instruction
+	  instruction-using-label
+	  instruction-with-literal
+	  instruction-with-location
+	  template
+	  computed-goto-instruction
+	  make-label
+	  note-environment
+	  note-source-code
+	  segment->template  ;plan
+	  segment-size
+	  sequentially
+
+	  ;; state
+	  debug-flag-names	; keep and flush commands
+	  debug-flag-accessor
+	  debug-flag-modifier
+	  debug-data-table
+	  get-debug-data
+	  with-fresh-compiler-state     ;for linker
+	  keep-source-code?		;for bcomp
+	  ))
+
+(define-interface compiler-interface
+  (export compile-forms
+          make-startup-procedure	;link/link.scm
+	  set-type-check?!		; for timings
+	  define-compilator		;assem.scm
+	  deliver-value			;assem.scm
+	  ))
+
+(define-interface primops-interface
+  (export define-compiler-primitive
+	  primop?
+	  primop-name
+	  primop-type
+	  primop-closed
+	  primop-compilator
+
+	  get-primop
+	  walk-primops			;comp-package.scm
+	  ))
+
+(define-interface debug-data-interface
+  (export debug-data-env-maps
+	  debug-data-name
+	  debug-data-parent
+	  debug-data-pc-in-parent
+	  debug-data-source
+	  debug-data-uid
+	  debug-data?
+	  set-debug-data-source!
+	  set-debug-data-env-maps!
+	  make-debug-data))
+
+;----------------
+; Module interfaces
+
+; Interfaces.
+
+(define-interface interfaces-interface
+  (export make-compound-interface
+	  make-simple-interface
+	  note-reference-to-interface!
+	  interface-ref
+	  interface?
+	  interface-clients
+	  for-each-declaration
+	  note-interface-name!))
+
+; Packages.
+
+(define-interface packages-interface
+  (export make-package
+	  make-simple-package		;start.scm
+	  make-structure
+	  package-define!
+	  package-lookup
+	  package?			;command.scm
+	  structure-lookup		;env.scm
+	  generic-lookup		;inline.scm
+	  structure-interface		;config.scm
+	  package->environment
+	  link!
+	  structure?
+	  package-uid			;reifier
+	  make-new-location		;ctop.scm
+	  structure-package
+	  note-structure-name!
+	  (:package :type)
+	  (:structure :type)))		;for (define-method ...)'s
+
+(define-interface packages-internal-interface
+  (export package-loaded?		;env/load-package.scm
+	  set-package-loaded?!		;env/load-package.scm
+	  package-name
+	  flush-location-names
+	  package-name-table		;debuginfo
+	  location-info-table		;debuginfo, disclosers
+	  package-unstable?		;env/pacman.scm
+	  package-integrate?		;env/debug.scm
+	  package-add-static!		;opt/analyze.scm
+	  package-refine-type!		;opt/usage.scm
+	  
+	  ;; For scanner
+	  for-each-export
+	  package-accesses
+	  package-clauses
+	  package-file-name
+	  package-opens
+	  set-package-integrate?!
+	  structure-name
+
+	  ;; For package mutation
+	  for-each-definition
+	  set-package-opens!
+	  set-structure-interface!
+	  set-package-opens-thunk!
+	  structure-clients
+	  package-opens-thunk
+	  package-opens-really
+	  package-undefineds
+	  package-undefined-but-assigneds
+	  package-note-caching!
+	  structure-interface-really
+	  make-new-location
+	  $get-location
+	  set-package-get-location!
+	  initialize-structure!
+	  initialize-package!
+	  location-for-reference
+
+	  package-cached
+	  package-definitions
+	  package-clients))
+
+(define-interface scan-package-interface
+  (export collect-packages
+	  package-source
+	  package-optimizer-names
+	  check-structure))
+
+(define-interface optimizer-interface
+  (export set-optimizer!
+	  get-optimizer))
+
+(define-interface undefined-interface
+  (export noting-undefined-variables
+	  $note-undefined		;env/command.scm
+	  ))
+
+;----------------
+; Inlining
+
+(define-interface inline-interface
+  (export make-inline-transform
+	  inline-transform		;bcomp/for-reify.scm
+	  qualified->name))
+
+(define-interface usages-interface
+  (export find-usages
+	  find-node-usages
+	  usage-name-node
+	  usage-reference-count
+	  usage-operator-count
+	  usage-assignment-count))
+
+; End of compiler interfaces
+;----------------
+
+(define-interface environments-interface  ;cheesy
+  (export *structure-ref
+	  environment-define!
+	  environment-ref
+	  environment-set!
+	  interaction-environment
+	  make-reflective-tower
+	  scheme-report-environment
+	  null-environment
+	  set-interaction-environment!
+	  set-scheme-report-environment!
+	  with-interaction-environment
+	  set-reflective-tower-maker!))
+
+(define-interface defpackage-interface
+  (export ((def			        ;Formerly define-structure
+	    define-interface		;Formerly define-signature
+	    define-structures		;Formerly define-package
+	    define-structure
+	    define-module
+	    define-syntax
+	    define-reflective-tower-maker
+	    export-reflective-tower-maker
+	    compound-interface
+	    export
+	    structure structures let	; New
+	    begin			; mostly for macros
+	    define			; for compatibility?
+	    a-package)			; cf. env/init-defpackage.scm
+	   :syntax)
+	  values
+	  interface-of
+	  set-verify-later!))
+
+(define-interface types-interface
+  (export ((:syntax :values :arguments :value) :type)
+	  (procedure (proc (:type :type) :type))  ; (procedure T1 T2)
+	  (proc :syntax)		; (proc (T1 ... Tn) T)
+	  ((:boolean
+	    :char
+	    :number
+	    :complex :real :rational :integer :exact-integer
+	    :null
+	    :unspecific
+	    :pair
+	    :string
+	    :symbol
+	    :vector
+	    :procedure
+	    :input-port :output-port
+	    :error
+	    :escape)
+	   :type)
+	  (:structure :type)
+	  :type))		;Holy stratification, Batman!
+
+(define-interface evaluation-interface
+  (export eval load load-into eval-from-file
+	  ; eval-scanned-forms
+	  ))
+
+; VM architecture
+
+(define-interface architecture-interface
+  (export (enum :syntax)  ;So you don't have to remember to open ENUMERATED
+	  (enumerand->name :syntax)
+	  (name->enumerand :syntax)
+	  bits-used-per-byte byte-limit
+	  (exception :enumeration)
+	  exception-count
+	  (interrupt :enumeration)
+	  interrupt-count
+	  (memory-status-option :enumeration)
+	  memory-status-option-count
+	  (op :enumeration)
+	  op-count
+	  opcode-arg-specs
+	  (stob :enumeration)
+	  stob-count
+	  stob-data
+	  (channel-status-option :enumeration)
+	  (time-option :enumeration)
+	  time-option-count
+	  (port-status-options :enumeration)
+	  (current-port-marker :syntax)
+
+	  maximum-stack-args
+	  two-byte-nargs-protocol
+	  two-byte-nargs+list-protocol
+	  args+nargs-protocol
+	  big-stack-protocol
+	  nary-dispatch-protocol
+
+	  default-stack-space
+	  environment-stack-size
+	  continuation-stack-size
+	  available-stack-space))
+
+(define-interface display-conditions-interface
+  (export display-condition		;command.scm
+	  &disclose-condition      	;env/disclosers.scm
+	  limited-write))
+
+; Bindings needed by the form composed by REIFY-STRUCTURES.
+
+(define-interface for-reification-interface
+  (export operator
+	  simple-interface
+	  package
+	  transform
+	  primop
+	  ;; From usual-macros
+	  usual-transform
+	  ;; From inline
+	  inline-transform
+	  ;; From packages
+	  package-define-static!
+	  ;; From primops
+	  make-structure
+	  ))
+
+;(define-interface command-interface ...)  -- moved to more-interfaces.scm
diff --git a/scheme/link-packages.scm b/scheme/link-packages.scm
new file mode 100644
index 0000000..85fd92d
--- /dev/null
+++ b/scheme/link-packages.scm
@@ -0,0 +1,86 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Static linker.  Doesn't work very well this way (debug info is
+; screwed up), so it's probably better to continue using linker.image
+; instead.
+
+(define-structure linker linker-interface
+  (open scheme-level-2
+	compiler write-images
+	debuginfo
+	segments		;with-fresh-compiler-state
+	packages
+	packages-internal       ;set-package-integrate?!
+	names			;name->symbol
+	scan-package		;collect-packages
+	compile-packages	;compile-package
+	reification
+	closures		;make closure to pass to write-image
+	filenames
+	debug-data		;with-fresh-compiler-state
+	locations
+	tables fluids signals util)
+  (files (link link)))
+
+(define-structure reification (export reify-structures)
+  (open scheme-level-2
+	packages
+	packages-internal ;?
+	usual-macros		;find-free-names-in-syntax-rules
+	names bindings
+	meta-types		;usual-variable-type
+	locations
+	primops
+	tables records
+	signals			;error
+	features		;force-output
+	util			;filter
+	inline)			;name->extrinsic
+  (files (link reify)))
+
+; Database of procedure names 'n' stuff.
+; (copy in more-packages.scm ...)
+
+(define-structure debuginfo debuginfo-interface
+  (open scheme-level-2
+	tables
+	debug-data
+	packages
+	packages-internal
+	syntactic
+	segments	;debug-data-table
+	features)       ;make-immutable!
+  (files (env debuginfo)))
+
+
+; Mumble.
+
+(define-structure flatloading (export flatload all-file-names)
+  (open scheme packages packages-internal filenames)
+  (files (env flatload)))
+
+(define-structure loadc (export load-configuration
+				;; (structure-ref :syntax)
+				)
+  (open scheme
+	environments		; *structure-ref
+	syntactic		; $source-file-name
+	fluids)
+  (files (link loadc)))
+
+
+; Everything.
+
+(define-structure link-config (export )  ;dummy structure...
+  (open scheme-level-2
+	linker
+	defpackage
+	types
+	analysis
+	loadc
+	flatloading
+	interfaces
+	signals)    ;warn
+  ;; (files (alt init-defpackage.scm))  -- or (env ...), depending
+  )
diff --git a/scheme/link/data.scm b/scheme/link/data.scm
new file mode 100644
index 0000000..0e23fc0
--- /dev/null
+++ b/scheme/link/data.scm
@@ -0,0 +1,139 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Scheme 48's data representations, for writing heap images.
+; Defines things needed by TRANSPORT (which is called by WRITE-IMAGE, which
+; is called by the static linker).
+; Adapted from vm/util.scm and vm/data.scm.
+
+
+(define (low-bits n k)
+  (bitwise-and n (- (arithmetic-shift 1 k) 1)))
+
+(define (high-bits n k)
+  (arithmetic-shift n (- 0 k)))
+
+(define (adjoin-bits high low width)
+  (bitwise-ior (arithmetic-shift high width) low))
+
+
+; Essential constants
+
+(define level          17)
+(define little-endian? #t)
+(define bits-per-byte  8)
+(define bytes-per-cell 4)
+(define bits-per-cell  (* bits-per-byte bytes-per-cell))
+(define addressing-units-per-cell 4)
+
+; This is actually the mimimum for the different PreScheme implementations.
+; The Scheme version of PreScheme leaves 30 bits for PreScheme's fixnums.
+; There have to be enough bits to represent the largest fixnum in the system.
+; USEFUL-BITS-PER-WORD is not written in the image.
+(define useful-bits-per-word      30)
+
+(define unused-field-width 2)
+
+(define tag-field-width 2)
+
+(define immediate-type-field-width
+  (- 8 tag-field-width))
+
+; Data descriptions copied from DATA.SCM
+
+(define-enumeration tag
+  (fixnum
+   immediate
+   header
+   stob))
+
+(define-enumeration imm
+  (false      ; #f
+   true       ; #t
+   char
+   unspecific
+   undefined
+   eof
+   null))
+
+(define bits-per-fixnum
+  (- (if (< bits-per-cell useful-bits-per-word)
+	 bits-per-cell
+	 useful-bits-per-word)
+     tag-field-width))
+
+(define	   least-fixnum-value (- 0 (arithmetic-shift 1 (- bits-per-fixnum 1))))
+(define greatest-fixnum-value (-   (arithmetic-shift 1 (- bits-per-fixnum 1))
+				   1))
+
+(define (fixnum? x)
+  (and (integer? x)
+       (>= x least-fixnum-value)
+       (<= x greatest-fixnum-value)))
+
+(define (immediate? x)
+  (or (fixnum? x)
+      (char? x)
+      (eq? x #t)
+      (eq? x '())    ; I think order is important here as () is a literal while
+      (eq? x #f)     ; #F is generated with an instruction.  If () = #f then
+		     ; we still lose on something like '(#F) (which is
+		     ; present in the system). 
+      ;; (eq? thing (unspecific))
+      ))
+
+(define car-offset 0)
+(define cdr-offset 1)
+
+(define closure-template-offset 0)
+(define closure-env-offset	1)
+
+(define location-contents-offset 1)
+(define location-id-offset     0)
+
+; Procedures for manipulating bits
+
+(define (make-descriptor tag data)
+  (adjoin-bits data tag tag-field-width))
+
+(define (make-immediate type info)
+  (make-descriptor (enum tag immediate)
+		   (adjoin-bits info type immediate-type-field-width)))
+
+(define vm-true	 (make-immediate (enum imm true)  0))
+(define vm-false (make-immediate (enum imm false) 0))
+(define vm-null	 (make-immediate (enum imm null)  0))
+(define vm-unspecific  (make-immediate (enum imm unspecific) 0))
+(define vm-unbound     (make-immediate (enum imm undefined) 1))
+(define vm-unassigned  (make-immediate (enum imm undefined) 2))
+
+(define header-type-field-width (- immediate-type-field-width 1))
+
+(define (make-header type length-in-bytes)
+  (make-descriptor (enum tag header) (adjoin-bits length-in-bytes
+					   type
+					   (+ 1 header-type-field-width))))
+
+(define (make-header-immutable header)
+  (bitwise-ior header (arithmetic-shift 1 (+ tag-field-width
+					     header-type-field-width))))
+
+(define (make-stob-descriptor addr)
+  (make-descriptor (enum tag stob) (a-units->cells addr)))
+
+(define (bytes->cells bytes)
+  (quotient (+ bytes (- bytes-per-cell 1))
+	    bytes-per-cell))
+
+(define (cells->bytes cells)
+  (* cells bytes-per-cell))
+
+(define (cells->a-units cells)
+  (adjoin-bits cells 0 unused-field-width))
+
+(define (a-units->cells cells)
+  (high-bits cells unused-field-width))
+
+(define (bytes->a-units byte-count)
+  (cells->a-units (bytes->cells byte-count)))
+
diff --git a/scheme/link/generate-c-header.scm b/scheme/link/generate-c-header.scm
new file mode 100644
index 0000000..de0dcc0
--- /dev/null
+++ b/scheme/link/generate-c-header.scm
@@ -0,0 +1,283 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; [This is a kludge.  Richard is loathe to include it in the
+; distribution.  But now the system itself uses it, so we're stuck.]
+
+; Reads arch.scm and data.scm and writes out a C .h file with constants
+; and macros for dealing with Scheme 48 data structures.
+
+; Needs Big Scheme.
+
+; (make-c-header-file "scheme48.h" "scheme48.h.in"
+;                     "vm/arch.scm" "vm/data.scm" "rts/record.scm")
+
+(define (make-c-header-file c-file c-in-file arch-file data-file record-file)
+  (receive (stob-list stob-data exception-list channel-status-list)
+      (search-file arch-file
+		   '("stob enumeration"
+		     "(define stob-data ...)"
+		     "exception enumeration"
+		     "channel-status enumeration")
+		   (defines-enum? 'stob)
+		   enum-definition-list
+		   (lambda (x)
+		     (and (eq? (car x) 'define)
+			  (eq? (cadr x) 'stob-data)))
+		   (lambda (x) (cadr (caddr x)))
+		   (defines-enum? 'exception)
+		   enum-definition-list
+		   (defines-enum? 'channel-status-option)
+		   enum-definition-list)
+    (receive (tag-list immediate-list)
+	(search-file data-file
+		     '("tag enumeration" "imm enumeration")
+		     (defines-enum? 'tag)
+		     enum-definition-list
+		     (defines-enum? 'imm)
+		     enum-definition-list)
+      (let ((record-type-fields
+	     (search-file record-file
+			  '("(define record-type-fields ...")
+			  (lambda (x)
+			    (and (eq? (car x) 'define)
+				 (eq? (cadr x) 'record-type-fields)))
+			  (lambda (x) (cadr (caddr x))))))
+	(with-output-to-file c-file
+	  (lambda ()
+	    (format #t "/* This file was generated automatically.~%")
+	    (format #t "   It's probably not a good idea to change it. */~%")
+	    (newline)
+	    (format #t "#ifndef _H_SCHEME48~%")
+	    (format #t "#define _H_SCHEME48~%")
+	    (newline)
+	    (copy-file c-in-file)
+	    (newline)
+	    (tag-stuff tag-list)
+	    (newline)
+	    (immediate-stuff immediate-list)
+	    (newline)
+	    (stob-stuff stob-list stob-data)
+	    (newline)
+	    (enumeration-stuff record-type-fields
+			       "S48_RECORD_TYPE_~A(x) S48_RECORD_REF((x), ~D)")
+	    (newline)
+	    (enumeration-stuff exception-list "S48_EXCEPTION_~A ~D")
+	    (newline)
+	    (enumeration-stuff channel-status-list
+		       "S48_CHANNEL_STATUS_~A S48_UNSAFE_ENTER_FIXNUM(~D)")
+	    (newline)
+	    (format #t "#endif /* _H_SCHEME48 */")
+	    (newline)))))))
+	  
+(define (tag-stuff tag-list)
+  (do ((tags tag-list (cdr tags))
+       (i 0 (+ i 1)))
+      ((null? tags))
+    (let ((name (upcase (car tags))))
+      (c-define "S48_~A_TAG ~D" name i)
+      (c-define "S48_~A_P(x) (((long)(x) & 3L) == S48_~A_TAG)" name name)))
+  (newline)
+  (c-define "S48_UNSAFE_ENTER_FIXNUM(n)   ((s48_value)((n) << 2))")
+  (c-define "S48_UNSAFE_EXTRACT_FIXNUM(x) ((long)(x) >> 2)"))
+
+(define (immediate-stuff imm-list)
+  (c-define "S48_MISC_IMMEDIATE(n) ((s48_value)(S48_IMMEDIATE_TAG | ((n) << 2)))")
+  (do ((imm imm-list (cdr imm))
+       (i 0 (+ i 1)))
+      ((null? imm))
+    (let ((name (upcase (car imm))))
+      (c-define "S48_~A    (S48_MISC_IMMEDIATE(~D))" name i)))
+  (newline)
+  (c-define "S48_ENTER_BOOLEAN(n) ((n) ? S48_TRUE : S48_FALSE)")
+  (c-define "S48_EXTRACT_BOOLEAN(x) ((x) != S48_FALSE)")
+  (newline)
+  (c-define "S48_UNSAFE_ENTER_CHAR(c) (S48_CHAR | ((c) << 8))")
+  (c-define "S48_UNSAFE_EXTRACT_CHAR(x) ((x) >> 8)")
+  (c-define "S48_CHAR_P(x) ((((long) (x)) & 0xff) == S48_CHAR)"))
+
+(define (stob-stuff stob-list stob-data)
+  (let ((type-mask (let ((len (length stob-list)))
+		     (do ((i 2 (* i 2)))
+			 ((>= i len) (- i 1))))))
+    (c-define "S48_ADDRESS_AFTER_HEADER(x, type) ((type *)((x) - S48_STOB_TAG))")
+    (c-define "S48_STOB_REF(x, i) (S48_ADDRESS_AFTER_HEADER(x, s48_value)[i])")
+    (c-define (string-append
+	       "S48_STOB_BYTE_REF(x, i) "
+	       "(((char *)S48_ADDRESS_AFTER_HEADER(x, s48_value))[i])"))
+    (c-define (string-append
+	       "S48_STOB_SET(x, i, v) "
+	       "do { "
+	       "s48_value __stob_set_x = (x); "
+	       "long __stob_set_i = (i); "
+	       "s48_value __stob_set_v = (v); "
+	       "if (S48_STOB_IMMUTABLEP(__stob_set_x)) "
+	       "s48_raise_argtype_error(__stob_set_x); "
+	       "else { "
+	       "S48_WRITE_BARRIER((__stob_set_x), "
+	       "(char *) (&S48_STOB_REF((__stob_set_x), (__stob_set_i))),"
+	       "(__stob_set_v)); "
+	       "*(&S48_STOB_REF((__stob_set_x), (__stob_set_i))) = (__stob_set_v); "
+	       "} "
+	       "} while (0)"))
+    (c-define (string-append
+	       "S48_STOB_BYTE_SET(x, i, v) "
+	       "do { "
+	       "char __stob_set_x = (x); "
+	       "long __stob_set_i = (i); "
+	       "s48_value __stob_set_v = (v); "
+	       "if (S48_STOB_IMMUTABLEP(__stob_set_x)) "
+	       "s48_raise_argtype_error(__stob_set_x); "
+	       "else "
+	       "*(&S48_STOB_BYTE_REF((__stob_set_x), (__stob_set_i))) = (__stob_set_v); "
+	       "} while (0)"))
+    (c-define "S48_STOB_TYPE(x)   ((S48_STOB_HEADER(x)>>2)&~D)" type-mask)
+    (c-define "S48_STOB_HEADER(x) (S48_STOB_REF((x),-1))")
+    (c-define "S48_STOB_ADDRESS(x) (&(S48_STOB_HEADER(x)))")
+    (c-define "S48_STOB_BYTE_LENGTH(x) (S48_STOB_HEADER(x) >> 8)")
+    (c-define "S48_STOB_DESCRIPTOR_LENGTH(x) (S48_STOB_HEADER(x) >> 10)")
+    (c-define "S48_STOB_IMMUTABLEP(x) ((S48_STOB_HEADER(x)>>7) & 1)")
+    (c-define "S48_STOB_MAKE_IMMUTABLE(x) ((S48_STOB_HEADER(x)) |= (1<<7))")
+    (newline)
+    (do ((stob stob-list (cdr stob))
+	 (i 0 (+ i 1)))
+	((null? stob))
+      (let ((name (upcase (car stob))))
+	(c-define "S48_STOBTYPE_~A ~D" name i)
+	(c-define "S48_~A_P(x) (s48_stob_has_type(x, ~D))" name i)))
+    (newline)
+    (for-each (lambda (data)
+		(let ((type (upcase (car data))))
+		  (do ((accs (cdddr data) (cdr accs))
+		       (i 0 (+ i 1)))
+		      ((null? accs))
+		    (let ((name (upcase (caar accs))))
+		      (c-define "S48_~A_OFFSET ~D" name i)
+		      (c-define "S48_~A(x) (s48_stob_ref((x), S48_STOBTYPE_~A, ~D))"
+				name type i)
+		      (c-define "S48_UNSAFE_~A(x) (S48_STOB_REF((x), ~D))" name i))
+		    (if (not (null? (cdar accs)))
+			(let ((name (upcase (cadar accs))))
+			  (c-define "S48_~A(x, v) (s48_stob_ref((x), S48_STOBTYPE_~A, ~D, (v)))"
+				    name type i)
+			  (c-define "S48_UNSAFE_~A(x, v) S48_STOB_SET((x), ~D, (v))" name i))))))
+	      stob-data)
+    (newline)
+    (for-each (lambda (type index)
+		(c-define "S48_~A_LENGTH(x) (s48_stob_length((x), S48_STOBTYPE_~A))"
+			  type type)
+		(c-define "S48_UNSAFE_~A_LENGTH(x) (STOB_DESCRIPTOR_LENGTH(x))"
+			  type)
+		(c-define "S48_~A_REF(x, i) (s48_stob_ref((x), S48_STOBTYPE_~A, ~A))"
+			  type type index)
+		(c-define "S48_~A_SET(x, i, v) (s48_stob_set((x), S48_STOBTYPE_~A, ~A, (v)))"
+			  type type index)
+		(c-define "S48_UNSAFE_~A_REF(x, i) (S48_STOB_REF((x), ~A))"
+			  type index)
+		(c-define "S48_UNSAFE_~A_SET(x, i, v) S48_STOB_SET((x), ~A, (v))"
+			  type index))
+	      '("VECTOR" "RECORD")
+	      '("(i)" "(i) + 1"))
+    (c-define "S48_RECORD_TYPE(x) (s48_stob_ref((x), S48_STOBTYPE_RECORD))")
+    (c-define "S48_UNSAFE_RECORD_TYPE(x) (STOB_REF((x), 0))")
+    (for-each (lambda (type)
+		(c-define "S48_~A_LENGTH(x) (s48_stob_byte_length((x), S48_STOBTYPE_~A))"
+			  type type)
+		(c-define "S48_~A_REF(x, i) (s48_stob_byte_ref((x), S48_STOBTYPE_~A, (i)))"
+			  type type)
+		(c-define "S48_~A_SET(x, i, v) (s48_stob_byte_set((x), S48_STOBTYPE_~A, (i), (v)))"
+			  type type)
+		(c-define "S48_UNSAFE_~A_REF(x, i) (S48_STOB_BYTE_REF((x), (i)))"
+			  type)
+		(c-define "S48_UNSAFE_~A_SET(x, i, v) S48_BYTE_STOB_SET((x), (i), (v))"
+			  type))
+	      '("BYTE_VECTOR" "STRING"))
+    (c-define "S48_UNSAFE_BYTE_VECTOR_LENGTH(x) (S48_STOB_BYTE_LENGTH(x))")
+    (c-define "S48_UNSAFE_STRING_LENGTH(x) (S48_STOB_BYTE_LENGTH(x) - 1)")
+    (c-define "S48_UNSAFE_EXTRACT_STRING(x) (S48_ADDRESS_AFTER_HEADER((x), char))")
+
+    (c-define (string-append "S48_EXTRACT_EXTERNAL_OBJECT(x, type) "
+			     "((type *)(S48_ADDRESS_AFTER_HEADER(x, long)+1))"))))
+
+(define (enumeration-stuff names format-string)
+  (do ((names names (cdr names))
+       (i 0 (+ 1 i)))
+      ((null? names))
+    (let ((name (upcase (car names))))
+      (c-define format-string name i))))
+
+; - becomes _ > becomes TO_ (so -> turns into _TO_)
+; ? becomes P
+; ! disappears
+
+(define (upcase symbol)
+  (do ((chars (string->list (symbol->string symbol)) (cdr chars))
+       (res '() (case (car chars)
+		  ((#\>) (append (string->list "_OT") res))
+		  ((#\-) (cons #\_ res))
+		  ((#\?) (cons #\P res))
+		  ((#\/ #\!) res)
+		  (else (cons (char-upcase (car chars)) res)))))
+      ((null? chars)
+       (list->string (reverse res)))))
+
+(define (c-define string . stuff)
+  (format #t "#define ~?~%" string stuff))
+    
+(define (defines-enum? name)
+  (lambda (x)
+    (and (eq? (car x) 'define-enumeration)
+	 (eq? (cadr x) name))))
+
+(define enum-definition-list caddr)
+
+; Copy the file to the current-output-file.
+
+(define (copy-file filename)
+  (call-with-input-file filename
+      (lambda (in)
+	(let loop ()
+	  (let ((c (read-char in)))
+	    (if (not (eof-object? c))
+		(begin
+		  (write-char c)
+		  (loop))))))))
+
+; WHAT-FOR is a list of names, used only for debugging.
+; PRED+EXTRACT is a list of <predicate0> <extract0> <predicate1> <extract1> ... .
+; Each form in the file is read and passed to the predicates that haven't yet
+; matched.  If the predicate matches the corresponding extractor is called on
+; the form.  The results of the extractors are returned.
+;
+; STUFF is list of ((predicate . extract) . name).  <name> is replaced
+; with the value when it is found.
+
+(define (search-file file what-for . pred+extract)
+  (let ((stuff (do ((p+e pred+extract (cddr p+e))
+		    (names what-for (cdr names))
+		    (ps '() (cons (cons (cons (car p+e) (cadr p+e))
+					(car names))
+				  ps)))
+		   ((null? p+e) (reverse ps)))))
+
+    (define (search next not-found)
+      (let loop ((n-f not-found) (checked '()))
+	(cond ((null? n-f)
+	       #f)
+	      (((caaar n-f) next)
+	       (set-cdr! (car n-f) ((cdaar n-f) next))
+	       (append (reverse checked) (cdr n-f)))
+	      (else
+	       (loop (cdr n-f) (cons (car n-f) checked))))))
+
+    (with-input-from-file file
+      (lambda ()
+	(let loop ((not-found stuff))
+	  (let ((next (read)))
+	    (cond ((null? not-found)
+		   (apply values (map cdr stuff)))
+		  ((eof-object? next)
+		   (error "file ~S doesn't have ~A" file (cdar not-found)))
+		  (else
+		   (loop (or (and (pair? next)
+				  (search next not-found))
+			     not-found))))))))))
diff --git a/scheme/link/generate-old-c-header.scm b/scheme/link/generate-old-c-header.scm
new file mode 100644
index 0000000..7a46667
--- /dev/null
+++ b/scheme/link/generate-old-c-header.scm
@@ -0,0 +1,160 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; This for compatibility with pre-0.53 code.
+
+; [This is a kludge.  Richard is loathe to include it in the
+; distribution.]
+
+; Reads arch.scm and data.scm and writes out a C .h file with constants
+; and macros for dealing with Scheme 48 data structures.
+
+; Needs Big Scheme.
+
+; (make-c-header-file "scheme48.h" "vm/arch.scm" "vm/data.scm")
+
+(define (make-c-header-file c-file arch-file data-file)
+  (receive (stob-list stob-data)
+      (search-file arch-file
+		   '("stob enumeration" "(define stob-data ...)")
+		   (defines-enum? 'stob)
+		   enum-definition-list
+		   (lambda (x)
+		     (and (eq? (car x) 'define)
+			  (eq? (cadr x) 'stob-data)))
+		   (lambda (x) (cadr (caddr x))))
+    (receive (tag-list immediate-list)
+	(search-file data-file
+		     '("tag enumeration" "imm enumeration")
+		     (defines-enum? 'tag)
+		     enum-definition-list
+		     (defines-enum? 'imm)
+		     enum-definition-list)
+      (with-output-to-file c-file
+	(lambda ()
+	  (format #t "typedef long scheme_value;~%~%")
+	  (tag-stuff tag-list)
+	  (newline)
+	  (immediate-stuff immediate-list)
+	  (newline)
+	  (stob-stuff stob-list stob-data))))))
+	  
+(define (tag-stuff tag-list)
+  (do ((tags tag-list (cdr tags))
+       (i 0 (+ i 1)))
+      ((null? tags))
+    (let ((name (upcase (car tags))))
+      (c-define "~A_TAG ~D" name i)
+      (c-define "~AP(x) (((long)(x) & 3L) == ~A_TAG)" name name)))
+  (newline)
+  (c-define "ENTER_FIXNUM(n)   ((scheme_value)((n) << 2))")
+  (c-define "EXTRACT_FIXNUM(x) ((long)(x) >> 2)"))
+
+(define (immediate-stuff imm-list)
+  (c-define "MISC_IMMEDIATE(n) (scheme_value)(IMMEDIATE_TAG | ((n) << 2))")
+  (do ((imm imm-list (cdr imm))
+       (i 0 (+ i 1)))
+      ((null? imm))
+    (let ((name (upcase (car imm))))
+      (c-define "SCH~A    MISC_IMMEDIATE(~D)" name i)))
+  (c-define "UNDEFINED SCHUNDEFINED")
+  (c-define "UNSPECIFIC SCHUNSPECIFIC")
+  (newline)
+  (c-define "ENTER_BOOLEAN(n) ((n) ? SCHTRUE : SCHFALSE)")
+  (c-define "EXTRACT_BOOLEAN(x) ((x) != SCHFALSE)")
+  (newline)
+  (c-define "ENTER_CHAR(c) (SCHCHAR | ((c) << 8))")
+  (c-define "EXTRACT_CHAR(x) ((x) >> 8)")
+  (c-define "CHARP(x) ((((long) (x)) & 0xff) == SCHCHAR)"))
+
+(define (stob-stuff stob-list stob-data)
+  (let ((type-mask (let ((len (length stob-list)))
+		     (do ((i 2 (* i 2)))
+			 ((>= i len) (- i 1))))))
+    (c-define "ADDRESS_AFTER_HEADER(x, type) ((type *)((x) - STOB_TAG))")
+    (c-define "STOB_REF(x, i) ((ADDRESS_AFTER_HEADER(x, long))[i])")
+    (c-define "STOB_TYPE(x)   ((STOB_HEADER(x)>>2)&~D)" type-mask)
+    (c-define "STOB_HEADER(x) (STOB_REF((x),-1))")
+    (c-define "STOB_BLENGTH(x) (STOB_HEADER(x) >> 8)")
+    (c-define "STOB_LLENGTH(x) (STOB_HEADER(x) >> 10)")
+    (newline)
+    (do ((stob stob-list (cdr stob))
+	 (i 0 (+ i 1)))
+	((null? stob))
+      (let ((name (upcase (if (eq? (car stob) 'byte-vector)
+			      'code-vector
+			      (car stob)))))
+	(c-define "STOBTYPE_~A ~D" name i)
+	(c-define "~AP(x) (STOBP(x) && (STOB_TYPE(x) == STOBTYPE_~A))"
+		  name name)))
+    (newline)
+    (for-each (lambda (data)
+		(do ((accs (cdddr data) (cdr accs))
+		     (i 0 (+ i 1)))
+		    ((null? accs))
+		  (let ((name (upcase (caar accs))))
+		    (c-define "~A(x) STOB_REF(x, ~D)" name i))))
+	      stob-data)
+    (newline)
+    (c-define "VECTOR_LENGTH(x) STOB_LLENGTH(x)")
+    (c-define "VECTOR_REF(x, i) STOB_REF(x, i)")
+    (c-define "CODE_VECTOR_LENGTH(x)  STOB_BLENGTH(x)")
+    (c-define "CODE_VECTOR_REF(x, i)  (ADDRESS_AFTER_HEADER(x, unsigned char)[i])")
+    (c-define "STRING_LENGTH(x)  (STOB_BLENGTH(x)-1)")
+    (c-define "STRING_REF(x, i)  (ADDRESS_AFTER_HEADER(x, char)[i])")))
+
+; - becomes _ > becomes TO_ (so -> turns into _TO_)
+; ? becomes P
+
+(define (upcase symbol)
+  (do ((chars (string->list (symbol->string symbol)) (cdr chars))
+       (res '() (case (car chars)
+		  ((#\>) (append (string->list "_OT") res))
+		  ((#\-) (cons #\_ res))
+		  ((#\?) (cons #\P res))
+		  (else (cons (char-upcase (car chars)) res)))))
+      ((null? chars)
+       (list->string (reverse res)))))
+
+(define (c-define string . stuff)
+  (format #t "#define ~?~%" string stuff))
+    
+(define (defines-enum? name)
+  (lambda (x)
+    (and (eq? (car x) 'define-enumeration)
+	 (eq? (cadr x) name))))
+
+(define enum-definition-list caddr)
+
+; STUFF is list of ((predicate . extract) . name).  <name> is replaced
+; with the value when it is found.
+
+(define (search-file file what-for . pred+extract)
+  (let ((stuff (do ((p+e pred+extract (cddr p+e))
+		    (names what-for (cdr names))
+		    (ps '() (cons (cons (cons (car p+e) (cadr p+e))
+					(car names))
+				  ps)))
+		   ((null? p+e) (reverse ps)))))
+
+    (define (search next not-found)
+      (let loop ((n-f not-found) (checked '()))
+	(cond ((null? n-f)
+	       #f)
+	      (((caaar n-f) next)
+	       (set-cdr! (car n-f) ((cdaar n-f) next))
+	       (append (reverse checked) (cdr n-f)))
+	      (else
+	       (loop (cdr n-f) (cons (car n-f) checked))))))
+
+    (with-input-from-file file
+      (lambda ()
+	(let loop ((not-found stuff))
+	  (let ((next (read)))
+	    (cond ((null? not-found)
+		   (apply values (map cdr stuff)))
+		  ((eof-object? next)
+		   (error "file ~S doesn't have ~A" file (cdar not-found)))
+		  (else
+		   (loop (or (and (pair? next)
+				  (search next not-found))
+			     not-found))))))))))
diff --git a/scheme/link/link.scm b/scheme/link/link.scm
new file mode 100644
index 0000000..f23cf94
--- /dev/null
+++ b/scheme/link/link.scm
@@ -0,0 +1,150 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; The static linker.
+
+; link-simple-system:
+; resumer-exp should evaluate to a procedure
+;   (lambda (arg i-port o-port ...) ...)
+
+(define (link-simple-system filename resumer-exp . structs)
+  (link-system structs (lambda () resumer-exp) filename))
+
+
+; resumer-exp should evaluate to a procedure
+;   (lambda (structs-thunk) ... (lambda (arg i-port o-port ...) ...))
+
+(define (link-reified-system some filename make-resumer-exp . structs)
+  (link-system (append structs (map cdr some))
+	       (lambda ()
+		 `(,make-resumer-exp
+		   (lambda ()
+		     ,(call-with-values
+			  (lambda () (reify-structures some))
+			(lambda (exp locs least-uid)
+			  `(,exp (lambda (i)
+				   (vector-ref ,(strange-quotation locs)
+					       (- i ,least-uid)))))))))
+	       filename))
+
+(define strange-quotation
+  (let ((operator/quote (get-operator 'quote)))
+    (lambda (thing)
+      (make-node operator/quote `',thing))))
+
+
+; `(,make-resumer-exp ',vector) should evaluate to a procedure
+;   (lambda (locs) ... (lambda (arg i-port o-port ...) ...))
+
+(define (link-semireified-system some filename
+				 make-resumer-exp . structs)
+  (let ((loser #f))
+    (link-system (append structs (map cdr some))
+		 (lambda ()
+		   (call-with-values (lambda ()
+				       (reify-structures some))
+		     (lambda (exp locs least)
+		       (set! loser exp)
+		       `(,make-resumer-exp ,(strange-quotation locs)
+					   ,least))))
+		 filename)
+    (let ((f (namestring filename #f 'env)))
+      (call-with-output-file f
+	(lambda (port)
+	  (display "Writing environment structure to ")
+	  (display f)
+	  (newline)
+	  ;; loser evaluates to a procedure
+	  ;;  (lambda (uid->location) struct-alist)
+	  (write `(define make-the-structures
+		    (,loser location-from-id))
+		 port))))))
+
+
+; (link-system structs make-resumer filename)
+;    structs is a list of structures to be compiled,
+;    make-resumer is a thunk which should return an expression, to be
+;      evaluated in a package that opens the given structures, that
+;      evaluates to the procedure to be called after all
+;      initializations are run, and
+;    filename is the name of the file to which the image should be written.
+
+(define (link-system structs make-resumer filename)
+  (with-fresh-compiler-state
+   (if *debug-linker?* 100000 0)    ;Location uid
+   (lambda ()
+     (set! *loser* #f)
+     (let* ((location-info (make-table))
+	    (generator (make-location-generator location-info
+						(if *debug-linker?* 10000 0)))
+	    (templates (compile-structures structs
+					   generator
+					   package->environment))
+	    (package (make-simple-package structs #f #f))
+	    (startup-template (begin
+				(set-package-get-location! package generator)
+				(expand&compile-form (make-resumer) package))))
+       (let ((startup (make-closure 
+		       (make-startup-procedure templates startup-template)
+		       0)))
+	 (if *debug-linker?* (set! *loser* startup))
+	 (write-image-file startup
+			   (namestring filename #f 'image)))
+       (write-debug-info location-info
+			 (namestring filename #f 'debug))))))
+
+
+(define (expand&compile-form form package)
+  (let* ((env (package->environment package))
+	 (template (compile-forms (map (lambda (form)
+					 (expand-scanned-form form env))
+				       (scan-forms (list form) env))
+				  #f)))	;filename
+    (link! template package #t)
+    template))
+
+(define *loser* #f)
+(define *debug-linker?* #f)
+
+(define (compile-structures structs generator package->env)
+  (let ((packages (collect-packages structs (lambda (package) #t)))
+	(out (current-noise-port)))
+    (for-each (lambda (package)
+		(set-package-get-location! package generator))
+	      packages)
+    (map (lambda (package)
+	   (display #\[ out)
+	   (display (package-name package) out)
+	   (let ((template (compile-package package)))
+	     (display #\] out)
+	     (newline out)
+	     template))
+	 packages)))
+
+; Locations in new image will have their own sequence of unique id's.
+
+(define (make-location-generator location-info start)
+
+  (let ((*location-uid* start))
+
+    (define (make-new-location p name)
+      (let ((uid *location-uid*))
+	(set! *location-uid* (+ *location-uid* 1))
+	(table-set! location-info uid
+		    (cons (name->symbol name) (package-uid p))) ;?
+	(make-undefined-location uid)))
+
+    make-new-location))
+
+
+(define (write-image-file start filename)
+  (write-image filename
+	       start
+	       "This heap image was made by the Scheme 48 linker."))
+
+
+
+; Handy utility for making arguments to link-reified-system
+
+(define-syntax struct-list
+  (syntax-rules ()
+    ((struct-list name ...) (list (cons 'name name) ...))))
diff --git a/scheme/link/loadc.scm b/scheme/link/loadc.scm
new file mode 100644
index 0000000..5d343a3
--- /dev/null
+++ b/scheme/link/loadc.scm
@@ -0,0 +1,21 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Cf. alt/config.scm
+
+(define (load-configuration filename . rest)
+  (let ((save filename))
+    (dynamic-wind (lambda () (set! *source-file-name* filename))
+		  (lambda ()
+		    (apply load filename rest))
+		  (lambda () (set! *source-file-name* save)))))
+(define (%file-name%) *source-file-name*)
+(define *source-file-name* "")
+
+
+; ?
+
+(define-syntax structure-ref
+  (syntax-rules ()
+    ((structure-ref ?struct ?name)
+     (*structure-ref ?struct '?name))))
diff --git a/scheme/link/reify.scm b/scheme/link/reify.scm
new file mode 100644
index 0000000..fc22356
--- /dev/null
+++ b/scheme/link/reify.scm
@@ -0,0 +1,283 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Structure reification.
+
+(define *least* #f)
+
+(define (reify-structures some)
+  (let* ((count 0)
+	 (least 1000000)
+	 (greatest -1000000)
+	 (locs (make-table))
+	 (loser (reify-structures-1 some
+				    (lambda (loc)
+				      (let ((id (location-id loc)))
+					(if (not (table-ref locs id))
+					    (begin 
+					      (if (< id least)
+						  (set! *least* loc))
+					      (set! least (min least id))
+					      (set! greatest (max greatest id))
+					      (set! count (+ count 1))
+					      (table-set! locs id loc)))
+					id))))
+	 (size (+ (- greatest least) 1)))
+    (write `(least ,least size ,size count ,count)) (newline)
+    (values loser
+	    (let ((v (make-vector size #f)))
+	      (table-walk (lambda (id loc)
+			    (vector-set! v (- id least) loc))
+			  locs)
+	      v)
+	    least)))
+
+
+; This is pretty gross.  We really want some kind of object dumper
+; instead.
+
+(define *objects* '())          ;List of (object . creation-form)
+(define *object-count* 0)
+(define *initializations* '())
+(define *deal-with-location* (lambda (loc) loc))
+(define *package-table* #f)     ;Entries are package-info structures
+
+
+; REIFY-STRUCTURES returns a form that evaluates to a procedure that
+; returns an alist of (name . structure).  deal-with-location is a
+; procedure that maps locations to labels for them (e.g. integers).
+; The procedure takes one argument, a procedure that will be applied
+; to the labels at startup time to re-obtain the corresponding
+; locations.
+
+(define (reify-structures-1 alist deal-with-location)
+  (flush-state)
+  (set! *deal-with-location* deal-with-location)
+
+  (display "Reifying") (force-output (current-output-port))
+
+  (let* ((result-form (reify-object alist))
+	 (shebang
+	  `(lambda (get-location)
+	     (let ((the-objects (make-vector ,*object-count* #f)))
+	       (begin ,@(map (lambda (init) (init))
+			     (reverse *initializations*)))
+	       (let ((structs ,result-form))
+		 (set! the-objects #f)	;SO IT CAN BE GC'D
+		 (set! get-location #f)
+		 structs)))))
+    (newline)
+    (if *reify-debug* (*reify-debug* shebang))
+
+    (flush-state)
+    (set! *deal-with-location* (lambda (loc) loc))
+
+    shebang))
+
+(define (flush-state)
+  (set! *objects* '())
+  (set! *object-count* 0)
+  (set! *initializations* '())
+  (set! *package-table* (make-table package-uid)))
+
+
+; Return an expression that will evaluate to thing.
+
+(define (reify-object thing)
+  (cond ((structure? thing)
+	 (let ((p-form (reify-package (structure-package thing))))
+	   (process-one-object
+	        thing
+		(lambda ()
+		  `(make-structure
+		    ,p-form
+		    ,(interface-expression thing)
+		    ',(structure-name thing)))
+		(lambda ()
+		  (process-exports thing p-form)
+		  (write-char #\. (current-output-port))
+		  (force-output (current-output-port))))))
+	((null? thing) ''())
+	((pair? thing)
+	 (if (list? thing)
+	     `(list ,@(map reify-object thing))
+	     `(cons ,(reify-object (car thing))
+		    ,(reify-object (cdr thing)))))
+	((symbol? thing)
+	 `',thing)
+	((transform? thing)
+	 (process-transform thing))
+	((operator? thing)
+	 `(operator ',(operator-name thing)
+		    ',(type->sexp (operator-type thing) #t)))
+	((primop? thing)
+	 `(primop ',(primop-name thing)))
+	;; ((interface? thing) ...)
+	(else (error "don't know how to reify this" thing))))
+
+(define (reify-package thing)
+  (process-one-object thing
+		      (lambda ()
+			(let ((bindings (package-info-bindings (package-info thing))))
+			  `(package
+			    ;; Each binding is a pair (name . loc)
+			    ',(list->vector (map car bindings)) ;names
+			    ',(list->vector (map cdr bindings)) ;location ids
+			    get-location
+			    ,(package-uid thing))))
+		      (lambda ()
+			(table-set! *package-table*
+				    thing
+				    (make-package-info)))))
+
+
+; General utility for uniquifying objects.
+
+(define (process-one-object obj make-creation-form when-new)
+  (let ((probe (assq obj *objects*)))
+    (if probe
+	(cdr probe)
+	(let* ((index *object-count*)
+	       (form `(vector-ref the-objects ,index)))
+	  (set! *object-count* (+ *object-count* 1))
+	  (set! *objects*
+		(cons (cons obj form) *objects*))
+	  (add-initialization!
+	    (lambda ()
+	      `(vector-set! the-objects ,index ,(make-creation-form))))
+	  (when-new)
+	  form))))
+
+(define (add-initialization! thunk)
+  (set! *initializations*
+	(cons thunk *initializations*)))
+
+
+; Add initializers that will create a structure's exported bindings.
+
+(define (process-exports struct p-form)
+  (let* ((package (structure-package struct))
+	 (info (package-info package)))
+    (for-each-export (lambda (name want-type binding)
+		       (if (not (process-one-binding name package info p-form))
+			   (warn "undefined export" name package)))
+		     struct)))
+
+
+; Packages...
+
+(define package-info-type
+  (make-record-type 'reify-info
+		    '(bindings  ;List of (name static-info location)
+		      table)))  ;Caches (assq? name bindings)
+
+(define (package-info package)
+  (table-ref *package-table* package))
+
+(define make-package-info
+  (let ((make (record-constructor package-info-type
+				  '(bindings table))))
+    (lambda ()
+      (make '()
+	    (make-name-table)))))
+
+(define package-info-bindings (record-accessor package-info-type 'bindings))
+(define package-info-table    (record-accessor package-info-type 'table))
+
+(define set-package-info-bindings!
+  (record-modifier package-info-type 'bindings))
+
+
+(define (process-one-binding name package info p-form)	; => #t iff bound
+  (let ((table (package-info-table info)))
+    (if (table-ref table name)
+	#t
+	(let ((binding (package-lookup package name)))
+	  (table-set! (package-info-table info) name #t)
+	  (if (binding? binding)
+	      (begin (really-process-one-binding name info binding p-form)
+		     #t)
+	      #f)))))
+
+(define (really-process-one-binding name info binding p-form)
+  (let ((static (binding-static binding))
+	(loc (*deal-with-location* (binding-place binding))))
+    (set-package-info-bindings!
+         info
+	 (cons (cons name loc)
+	       (package-info-bindings info)))
+    (if static
+	(add-package-define! p-form name (reify-object static)))))
+
+(define (add-package-define! p-form name s-form)
+  (add-initialization!
+   (lambda ()
+     `(package-define-static! ,p-form
+			      ',name
+			      ,s-form))))
+
+(define (process-transform transform)
+  (let ((name (transform-id transform))
+	(env (transform-env transform)))
+    (let ((env-form
+	   (if (package? env)
+	       (reify-package env)
+	       (reify-object env))))
+      (process-one-object
+       transform
+       (let ((source (transform-source transform)))
+	 (lambda ()
+	   `(transform ,source		;transformer
+		       ,env-form
+		       ',(type->sexp (transform-type transform) #t) ;type
+		       #f		;',source  -- omitted to save space...
+		       ',name)))
+       (if (package? env)
+	   (lambda ()
+	     (let ((info (package-info env)))
+	       (for-each (lambda (name)
+			   (process-one-binding name env info env-form))
+			 (or (transform-aux-names transform) ; () must be true
+			     (begin
+			       (warn "reified macro's auxiliary bindings are unknown"
+				     name)
+			       '())))))
+	   (lambda () #f))))))
+
+
+(define (interface-expression struct)
+  (let ((names '())
+	(types '()))
+    (for-each-export (lambda (name type binding)
+		       (set! names (cons name names))
+		       (set! types (cons (if (eq? type undeclared-type)
+					     ':undeclared
+					     (type->sexp type #t))
+					 types)))
+		     struct)
+    `(simple-interface ',(list->vector names) ',(list->vector types))))
+
+
+; The compiler doesn't like to see unusual objects quoted, but this will
+; fake it out.
+
+(define strange-quotation
+  (let ((operator/literal (get-operator 'literal)))
+    (define (normal? thing)
+      (or (number? thing)
+	  (and (vector? thing)
+	       (every normal? (vector->list thing)))))
+    (lambda (thing)
+      (if (normal? thing)
+	  `',thing
+	  (make-node operator/literal thing)))))
+
+
+(define *reify-debug*  ;#f
+  (let ((fn "build/reify-debug.tmp"))
+    (lambda (x) (call-with-output-file fn
+		  (lambda (port)
+		    (display "Writing linker debug file ")
+		    (display fn) (force-output (current-output-port))
+		    (write x port)
+		    (newline))))))
diff --git a/scheme/link/transport.scm b/scheme/link/transport.scm
new file mode 100644
index 0000000..7cd6aa7
--- /dev/null
+++ b/scheme/link/transport.scm
@@ -0,0 +1,283 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; This is file transport.scm.
+
+; System builder for bootstrapping and debugging.
+
+; Things that have to be written out:
+;  Made by the compiler
+;   closures
+;   templates
+;   code-vectors
+;   locations
+;  Quoted data
+;   symbols
+;   pairs
+;   vectors
+;   strings
+;   booleans
+;   characters
+
+; Convert THING to the Scheme 48 virtual machine's representation and
+; return it.  Locations and symbols may have multiple references in
+; the image.  Their transported addresses are kept in a table.
+
+(define (transport thing)
+  (let transport ((thing thing))
+    (cond ((immediate? thing)
+           (transport-immediate thing))
+          ((closure? thing)
+           (transport-closure thing))
+          ((code-vector? thing)
+           (allocate-b-vector thing code-vector-length))
+          ((location? thing)
+           (let ((address (table-ref *locations* thing)))
+             (cond (address address)
+                   (else
+                    (let ((desc (transport-location thing)))
+                      (table-set! *locations* thing desc)
+                      desc)))))
+          ((symbol? thing)
+           (let ((address (table-ref *symbols* thing)))
+             (cond (address address)
+                   (else
+                    (let ((desc (transport-symbol thing)))
+                      (table-set! *symbols* thing desc)
+                      desc)))))
+          ((pair? thing)
+           (transport-pair thing))
+          ((template? thing)
+           (transport-template thing))
+          ((vector? thing)
+           (transport-vector thing))
+          ((string? thing)
+           (allocate-b-vector thing (lambda (x) (+ 1 (string-length x)))))
+          (else
+           (error "cannot transport object" thing)))))
+
+; Transport the things that are not allocated from the heap.
+
+(define (transport-immediate thing)
+  (cond ((integer? thing)
+         (make-descriptor (enum tag fixnum) thing))
+        ((char? thing)
+         (make-immediate (enum imm char) (char->ascii thing)))
+        ((eq? thing '())
+         vm-null)
+        ((eq? thing #f)
+         vm-false)
+        ((eq? thing #t)
+         vm-true)
+        ((eq? thing (unspecific))
+         vm-unspecific)
+        (else
+         (error "cannot transport literal" thing))))
+
+;==============================================================================
+; The heap is a list of transported stored objects, each of which is either a
+; string, a code-vector, or a vector of length N+1 representing a stored object
+; with N cells.  The last slot of the vector is the object's header.
+
+(define *heap* '())
+
+(define *hp* 0)       ; Current heap-pointer (in a-units)
+
+(define *symbols* #f)    ; Table of already-transported symbols
+
+(define *locations* #f)  ; Table of already-transported locations
+
+(define (initialize-memory)
+  (set! *hp*      0)
+  (set! *heap*    '())
+  (set! *symbols* (make-table))
+  (set! *locations* (make-table location-id)))
+
+; Allocate a new stored object in the heap.  DATA is whatever data is
+; associated with the object, LEN is the length of the object (not
+; including the header) in bytes.  A pointer to the new object is
+; returned.
+
+(define (allocate-stob data len)
+  (let ((addr (+ *hp* (cells->a-units 1))))   ; move past header
+    (set! *hp* (+ addr (bytes->a-units len)))
+    (set! *heap* (cons data *heap*))
+    (make-stob-descriptor addr)))
+
+; Allocate a new stored object that contains descriptors.  This
+; creates a vector to hold the header and the object's tranported
+; contents and allocates a stob in the heap.  Returns a pair
+; containing the stob-pointer and the vector.
+
+(define (allocate-d-vector type cells immutable?)
+  (let* ((vec (make-vector (+ cells 1) 0))
+         (ptr (allocate-stob vec (cells->bytes cells)))
+         (hdr (make-header type (cells->bytes cells))))
+    (vector-set! vec cells (if immutable? (make-header-immutable hdr) hdr))
+    (cons ptr vec)))
+
+; Allocate a new stored object that contains data.  VEC is either a
+; code-vector or a string.
+
+(define (allocate-b-vector vec length)
+  (let ((len (cells->bytes (bytes->cells (length vec)))))
+    (allocate-stob vec len)))
+
+;==============================================================================
+; Transport an object with two slots.  ALLOCATE-D-VECTOR allocates the
+; storage and then the two values are transported.
+
+(define (transport-two-slot type accessor1 offset1 accessor2 offset2
+                            immutable?)
+  (lambda (thing)
+    (let* ((data (allocate-d-vector type 2 immutable?))
+           (descriptor (car data))
+           (vector (cdr data)))
+      (vector-set! vector offset1 (transport (accessor1 thing)))
+      (vector-set! vector offset2 (transport (accessor2 thing)))
+      descriptor)))
+
+; Closures and pairs are transported using TRANSPORT-TWO-SLOT.
+
+(define transport-closure
+  (transport-two-slot (enum stob closure)
+                      closure-template closure-template-offset
+                      closure-env      closure-env-offset
+                      #t))  ; ***
+
+(define transport-pair
+  (transport-two-slot (enum stob pair)
+                      car car-offset
+                      cdr cdr-offset
+                      #t))  ; *** ?
+
+; Transporting a location requires some care so as to avoid calling CONTENTS
+; when the location is unbound.
+
+(define (transport-location loc)
+  (let* ((data (allocate-d-vector (enum stob location) 2 #f))
+         (descriptor (car data))
+         (vector (cdr data)))
+    (vector-set! vector
+                 location-contents-offset
+                 (if (location-defined? loc)
+                     (transport (contents loc))
+                     vm-unbound))
+    (vector-set! vector
+                 location-id-offset
+                 (transport (location-id loc)))
+    descriptor))
+
+; Symbols have two slots, the string containing the symbol's name and a slot
+; used in building the symbol table.
+; Characters in the symbol name are made to be lower case.
+
+(define (transport-symbol symbol)
+  (let* ((data (allocate-d-vector (enum stob symbol) 2 #t))
+         (descriptor (car data))
+         (vector (cdr data)))
+    (vector-set! vector
+                 0
+                 (transport (symbol-case-converter (symbol->string symbol))))
+    (vector-set! vector
+                 1
+                 (transport #f))
+    descriptor))
+
+(define (string-case-converter string)
+  (let ((new (make-string (string-length string) #\x)))
+    (do ((i 0 (+ i 1)))
+        ((>= i (string-length new))
+         new)
+      (string-set! new i (preferred-case (string-ref string i))))))
+
+;(define preferred-case                  ;Copied from rts/read.scm
+;  (if (char=? (string-ref (symbol->string 't) 0) #\T)
+;      char-upcase
+;      char-downcase))
+(define preferred-case char-downcase)
+
+(define symbol-case-converter
+  (if (char=? (string-ref (symbol->string 't) 0)
+              (preferred-case #\t))
+      (lambda (string) string)
+      string-case-converter))
+
+; Templates and vectors have an arbitrary number of slots but are otherwise
+; the same as pairs and closures.
+
+(define (transport-template template)
+  (transport-vector-like template
+                         (enum stob template)
+                         (template-length template)
+                         template-ref
+                         #f))
+
+(define (transport-vector vector)
+  (transport-vector-like vector
+                         (enum stob vector)
+                         (vector-length vector)
+                         vector-ref
+                         #t))  ;***
+
+(define (transport-vector-like vector type length ref immutable?)
+  (let* ((data (allocate-d-vector type length immutable?))
+         (descriptor (car data))
+         (new (cdr data)))
+    (do ((i 0 (+ i 1)))
+        ((>= i length))
+      (vector-set! new i (transport (ref vector i))))
+    descriptor))
+
+;==============================================================================
+; Writing the heap out to a port.
+
+(define (write-heap port)
+  (do ((heap (reverse *heap*) (cdr heap)))
+      ((null? heap))
+    (write-heap-stob (car heap) port)))
+
+; Dispatch on the type of THING and call WRITE-STOB.
+
+(define (write-heap-stob thing port)
+  (cond ((string? thing)
+         (let ((len (+ 1 (string-length thing))))
+           (write-stob (make-header-immutable ; ***
+                        (make-header (enum stob string) len))
+                       thing len nulled-string-ref write-char port)
+           (align-port len port)))
+        ((code-vector? thing)
+         (let ((len (code-vector-length thing)))
+           (write-stob (make-header-immutable  ; ***
+                        (make-header (enum stob byte-vector) len))
+                       thing len code-vector-ref write-byte port)
+           (align-port len port)))
+        ((vector? thing)
+         (let ((len (vector-length thing)))
+           (write-stob (vector-ref thing (- len 1))
+                       thing (- len 1) vector-ref write-descriptor port)))
+        (else
+         (error "do not know how to write stob" thing))))
+
+(define (nulled-string-ref string i)
+  (if (= i (string-length string))
+      (ascii->char 0)
+      (string-ref string i)))
+
+; Write out a transported STOB to PORT.  HEADER is the header, LENGTH is the
+; number of objects the STOB contains, ACCESSOR and WRITER access the contents
+; and write them to the heap.
+
+(define (write-stob header contents length accessor writer port)
+  (write-descriptor header port)
+  (do ((i 0 (+ i 1)))
+      ((>= i length))
+    (writer (accessor contents i) port)))
+
+; Write out zeros to align the port on a four-byte boundary.
+
+(define (align-port len port)
+  (let ((count (- (cells->bytes (bytes->cells len)) len)))
+    (do ((count count (- count 1)))
+        ((<= count 0))
+      (write-byte 0 port))))
+
diff --git a/scheme/link/write-image.scm b/scheme/link/write-image.scm
new file mode 100644
index 0000000..03d2200
--- /dev/null
+++ b/scheme/link/write-image.scm
@@ -0,0 +1,66 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Writing out a Scheme 48 image
+
+(define (write-image file start-proc id-string)
+  (if (not (= 0 (remainder bits-per-cell bits-per-io-byte)))
+      (error "io-bytes to not fit evenly into cells"))
+  (initialize-memory)
+  (call-with-output-file file
+    (lambda (port)
+      (let ((start (transport start-proc))  ; transport the start-proc
+	    (false (transport #f)))
+	(display id-string port)
+	(newline port)
+	(write-page port)
+	(newline port)
+	(display architecture-version port)
+	(newline port)
+	(boot-write-number bytes-per-cell        port)
+	(boot-write-number 0                     port)   ; newspace begin
+	(boot-write-number (a-units->cells *hp*) port)
+	(boot-write-number false                 port)   ; symbol table
+	(boot-write-number false                 port)   ; imported bindings
+	(boot-write-number false                 port)   ; exported bindings
+	(boot-write-number false                 port)   ; resumer records
+	(boot-write-number start                 port)   ; start-proc
+	(write-page port)
+	(write-descriptor 1 port)	; endianness indicator
+	(write-heap port))))		; write out the heap
+  )
+
+(define bits-per-io-byte 8)    ; for writing images
+
+(define (write-page port)
+  (write-char (ascii->char 12) port))
+
+(define (write-byte byte port)
+  (write-char (ascii->char byte) port))
+  
+(define io-byte-mask
+  (low-bits -1 bits-per-io-byte))
+
+;(define bits-per-cell    -- defined in data.scm
+;  (* bits-per-byte bytes-per-cell))
+
+(define (big-endian-write-descriptor thing port)
+  (let loop ((i (- bits-per-cell bits-per-io-byte)))
+    (cond ((>= i 0)
+           (write-byte (bitwise-and io-byte-mask
+				    (arithmetic-shift thing (- 0 i))) port)
+           (loop (- i bits-per-io-byte))))))
+
+(define (little-endian-write-descriptor thing port)
+  (let loop ((i 0))
+    (cond ((< i bits-per-cell)
+           (write-byte (bitwise-and io-byte-mask
+				    (arithmetic-shift thing (- 0 i))) port)
+           (loop (+ i bits-per-io-byte))))))
+
+(define write-descriptor little-endian-write-descriptor)
+
+(define (boot-write-number n port)
+  (display n port)
+  (newline port))
+
diff --git a/scheme/low-packages.scm b/scheme/low-packages.scm
new file mode 100644
index 0000000..fea64b9
--- /dev/null
+++ b/scheme/low-packages.scm
@@ -0,0 +1,34 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Things provided by the byte compiler / VM, together with a few
+; things with rather sensitive definitions (low.scm).
+
+(define-structures ((scheme-level-0 scheme-level-0-interface)
+		    (primitives primitives-interface)
+		    (bitwise bitwise-interface)
+		    (closures closures-interface)
+		    (byte-vectors byte-vectors-interface)
+		    (code-vectors code-vectors-interface)
+		    (write-images (export write-image))	;for linker
+		    (source-file-names (export (%file-name% :syntax)))
+		    (loopholes (export (loophole :syntax)))
+		    (low-level low-level-interface)
+		    (escapes escapes-interface)
+		    (vm-exposure vm-exposure-interface)
+		    (ascii ascii-interface)
+		    (locations locations-interface)
+		    (low-channels low-channels-interface)
+		    (ports ports-interface)
+		    (shared-bindings shared-bindings-interface)
+		    (signals signals-interface)
+		    (debug-messages (export debug-message))
+		    (silly (export reverse-list->string))
+		    (code-quote (export (code-quote :syntax)))
+		    (structure-refs (export (structure-ref :syntax))))
+  (define-all-operators)		; Primitive Scheme, in the LSC paper
+  (usual-transforms and cond do let let* or)
+  (files (rts low)
+	 (rts signal))
+  (optimize auto-integrate))
+
diff --git a/scheme/misc/annotate.scm b/scheme/misc/annotate.scm
new file mode 100644
index 0000000..5c83cba
--- /dev/null
+++ b/scheme/misc/annotate.scm
@@ -0,0 +1,39 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+
+; Derived from
+;  (lambda (x y) (cons (car x) (cdr x)))
+
+(define annotate-procedure
+  (lap annotate-procedure ()
+       0 (check-nargs= 2)
+       2 (make-env 2)
+       4 (local0 2)
+       6 (stored-object-ref closure 0)
+       9 (push)
+       10 (local0 2)
+       12 (stored-object-ref closure 1)
+          (push)
+	  (local0 1)
+       15 (make-stored-object 3 closure)
+       18 (return)))
+
+; Derived from
+;  (lambda (x) (if (< 2 (vector-length x)) (vector-ref x 2) #f))
+
+(define procedure-annotation
+  (lap procedure-anotation ()
+       0 (check-nargs= 1)
+       2 (make-env 1)
+       4 (literal '2)
+       6 (push)
+       7 (local0 1)
+       9 (stored-object-length closure)
+       11 (<)
+       12 (jump-if-false (=> 23))
+       15 (local0 1)
+       20 (stored-object-ref closure 2)
+       22 (return)
+       23 (false)
+       24 (return)))
diff --git a/scheme/misc/doodl.scm b/scheme/misc/doodl.scm
new file mode 100644
index 0000000..0273582
--- /dev/null
+++ b/scheme/misc/doodl.scm
@@ -0,0 +1,299 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Dilapidated Object-Oriented Dynamic Language
+; Dynamic Object-Oriented Dynamic Language
+; Drug-crazed Object-Oriented Dynamic Language
+
+; Written for clarity, not for speed.
+
+; Tests are in test-doodl.scm.
+
+(define <object>     :value)
+(define <number>     :number)
+(define <complex>    :complex)
+(define <real>	     :real)
+(define <rational>   :rational)
+(define <integer>    :integer)
+(define <pair>	     :pair)
+(define <symbol>     :symbol)
+(define <char>	     :char)
+(define <null>	     :null)
+(define <vector>     :vector)
+(define <string>     :string)
+(define <eof-object> :eof-object)
+(define <function>   :procedure)
+(define <input-port> :input-port)
+(define <output-port> :output-port)
+
+
+; --------------------
+; Generic functions
+
+(define method-table? (type-predicate :method-table))
+
+(define-syntax define-generic-function
+  (syntax-rules (setter)
+    ((define-generic-function (setter ?name) ?parameter-list) ;for define-slot
+     (define-setter ?name
+       (make-generic-function
+	    '(setter ?name)
+	    (method-info ?name ("next" next-method . ?parameter-list)
+	      (next-method)))))
+    ((define-generic-function ?name ?parameter-list)
+     (define ?name
+       (make-generic-function
+	    '?name
+	    (method-info ?name ("next" next-method . ?parameter-list)
+	      (next-method)))))))
+	
+(define (make-generic-function id prototype)
+  (let ((mtable (make-method-table id prototype)))
+    (annotate-procedure (make-generic mtable) mtable)))
+
+(define (generic-function? f)
+  (and (procedure? f)
+       (method-table? (procedure-annotation f))))
+
+(define-simple-type <generic-function> (<function>) generic-function?)
+
+(define-method &add-method! ((g <generic-function>) foo)
+  (add-method! (procedure-annotation g) foo))
+
+(define-method &disclose ((g <generic-function>))
+  `(generic-function ,(method-table-id (procedure-annotation g))))
+
+(define method-table-id (record-accessor :method-table 'id))
+
+; --------------------
+; Method info (applicability / action pairs)
+
+; D***n-style METHOD syntax
+
+(define-syntax method
+  (syntax-rules ()
+    ((method ?specs ?body ...)
+     (make-method (method-info anonymous ?specs ?body ...)))))
+
+(define method-table-methods (record-accessor :method-table 'methods))
+
+(define (make-method info)
+  (letrec ((perform (methods->perform
+		      (list info
+			    (method-info method args
+			      (apply call-error "invalid arguments" m args)))
+		      ;; This oughta be a prototype
+		      #f))
+	   (m (annotate-procedure (lambda args (perform args))
+				  info)))
+    m))
+
+(define method-info? (record-predicate :method-info))
+
+(define (method? f)
+  (and (procedure? f)
+       (method-info? (procedure-annotation f))))
+
+(define-simple-type <method> (<function>) method?)
+
+(define-method &disclose ((m <method>))
+  `(method ,(procedure-annotation m)))
+
+; --------------------
+; (SETTER foo)
+
+(define-syntax setter
+  (lambda (e r c)
+    (string->symbol (string-append (symbol->string (cadr e))
+				   "-"
+				   (symbol->string 'setter)))))
+
+(define-syntax define-setter  ;for define-slot
+  (lambda (e r c)
+    `(,(r 'define)
+      ,(string->symbol (string-append (symbol->string (cadr e))
+				      "-"
+				      (symbol->string 'setter)))
+      ,(caddr e))))
+
+(define-syntax set
+  (syntax-rules ()
+    ((set (?fun ?arg ...) ?val)
+     ((setter ?fun) ?arg ... ?val))
+    ((set ?var ?val)
+     (set! ?var ?val))))
+
+(define car-setter set-car!)
+(define cdr-setter set-cdr!)
+(define vector-ref-setter vector-set!)
+
+; --------------------
+; DEFINE-CLASS
+
+(define-syntax define-class
+  (syntax-rules ()
+    ((define-class ?class-name (?super ...) ?slot ...)
+     (begin (define-slot ?slot)
+	    ...
+	    (define ?class-name
+              (make-class (list ?super ...)
+			  (list ?slot ...)
+                          '?class-name))))))
+
+(define-syntax define-slot
+  (syntax-rules ()
+    ((define-slot ?slot)
+     (begin (define-generic-function ?slot (x))
+	    (define-generic-function (setter ?slot) (x new-val))
+	    (define-method ?slot ((x <instance>))
+	      (instance-slot-ref x ?slot))
+	    (define-method (setter ?slot) ((x <instance>) new-val)
+	      (instance-slot-set! x ?slot new-val))))))
+
+; Instances
+
+(define-record-type instance <instance>
+  (make-instance classes slots)
+  instance?
+  (classes instance-classes)
+  (slots instance-slot-values))
+
+(define (instance-slot-ref instance slot)
+  (cond ((assq slot (instance-slot-values instance)) => cdr)
+	(else (call-error "no such slot"
+			  instance-slot-ref instance slot))))
+
+(define (instance-slot-set! instance slot new-value)
+  (cond ((assq slot (instance-slot-values instance))
+	 => (lambda (z) (set-cdr! z new-value)))
+	(else (call-error "no such slot"
+			  instance-slot-set! instance slot new-value))))
+
+; Classes
+
+(define-record-type class <class>
+  (really-make-class classes predicate priority slots id)
+  class?
+  (classes class-classes)
+  (predicate class-predicate)
+  (priority class-priority)
+  (slots class-slots)
+  (id class-id))
+
+(define-record-discloser <class>
+  (lambda (c) `(class ,(class-id c))))
+
+(define-method &type-predicate ((c <class>)) (class-predicate c))
+(define-method &type-priority ((c <class>)) (class-priority c))
+
+(define (make-class supers slots id)
+  (letrec ((class
+	    (really-make-class
+	         (reduce unionq '() (map get-classes supers))
+		 (lambda (x)		;Predicate
+		   (and (instance? x)
+			(memq class (instance-classes x))))
+		 (if (null? supers)	;Priority
+		     (type-priority <instance>)
+		     (+ (apply max (map type-priority supers))
+			*increment*))
+		 (unionq slots
+			 (reduce unionq '() (map get-slots supers)))
+		 id)))
+    class))
+
+(define *increment* 10)
+
+(define (get-classes type)
+  (if (class? type)
+      (cons type
+	    (class-classes type))
+      '()))
+
+(define (get-slots type)
+  (if (class? type)
+      (class-slots type)
+      '()))
+
+(define-generic-function make (class . key/value-pairs))
+
+(define-method make ((c <class>) . key/value-pairs)
+  (let ((i (make-instance (cons c (class-classes c))
+			  (map (lambda (slot)
+				 (cons slot '*uninitialized*))
+			       (class-slots c)))))
+    (apply initialize i key/value-pairs)
+    i))
+
+(define-generic-function initialize (i . key/value-pairs))
+
+(define-method initialize ((i <instance>)) (unspecific))
+
+
+(define (unionq l1 l2)
+  (cond ((null? l1) l2)
+	((null? l2) l1)
+	((memq (car l1) l2) (unionq (cdr l1) l2))
+	(else (cons (car l1) (unionq (cdr l1) l2)))))
+
+; --------------------
+; Random
+
+(define id? eq?)
+
+(define-syntax bind
+  (lambda (e r c)
+    (if (and (pair? (cdr e))
+	     (list? (cadr e)))
+	(let ((%call-with-values (r 'call-with-values))
+	      (%lambda (r 'lambda))
+	      (%method (r 'method))
+	      (%begin (r 'begin)))
+	  (let recur ((specs (cadr e)))
+	    (if (null? specs)
+		`(,%begin ,@(cddr e))
+		(let ((rspec (reverse (car specs))))
+		  `(,%call-with-values
+		    (,%lambda () ,(car rspec))
+		    (,%method ,(reverse (cdr rspec))
+			      ,(recur (cdr specs))))))))
+	e)))
+
+(define-simple-type <list> (<object>) list?)
+
+; --------------------
+; More?
+
+; (instance? obj class)
+; (as class object) => instance
+
+; <type>
+; (union type1 type2)
+; (union* type ...)
+; (subtype? type1 type2 )
+;   per design note 05
+
+; (define-method foo (x y #values (foo <integer>)) ...)
+;   per design note 21
+
+; (define-method f ((x (limited <integer> min: -1000 max: 1000)) ...) 
+;   ...)
+;   design note 06
+
+; <collection>, etc.
+
+
+; <exact> and <inexact> ?
+
+;(define <sequence>
+;  (make-generalization (list <list> <vector> <string>) '<sequence>))
+
+;(define <port>
+;  (make-generalization (list <input-port> <output-port>) '<port>))
+
+
+; Need reader syntax:
+;   #next #rest #key   etc.
+;     - implement with (define-sharp-macro #\n ...) ?
+;   keywords - foo:  
+;     - implement by customizing parse-token
diff --git a/scheme/misc/either.scm b/scheme/misc/either.scm
new file mode 100644
index 0000000..433cf15
--- /dev/null
+++ b/scheme/misc/either.scm
@@ -0,0 +1,90 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Internal variable representing the failure stack.
+
+(define (fail) (*fail*))
+
+(define *fail* (lambda () (error "You didn't do (init).")))
+
+
+; For the alternation operator, Icon's a | b or McCarthy's (amb a b),
+; we write (either a b).
+
+(define-syntax either
+  (syntax-rules ()
+    ((either) (fail))
+    ((either x) x)
+    ((either x y ...)
+     (%either (lambda () x) (lambda () (either y ...))))))
+
+(define (%either thunk1 thunk2)		;Macro auxiliary
+  (saving-failure-state
+   (lambda (restore)
+     ((call-with-current-continuation
+	(lambda (k)
+	  (set! *fail*
+		(lambda ()
+		  (restore)
+		  (k thunk2)))
+	  thunk1))))))
+
+(define (saving-failure-state proc)
+  (let ((save *fail*))
+    (proc (lambda () (set! *fail* save)))))
+
+
+; (one-value x) is Prolog's CUT operator
+
+(define-syntax one-value
+  (syntax-rules ()
+    ((one-value x) (%one-value (lambda () x)))))
+
+(define (%one-value thunk)
+  (saving-failure-state
+   (lambda (restore)
+     (let ((value (thunk)))
+       (restore)
+       value))))
+
+
+; (all-values a) returns a list of all the possible values of the
+; expression a.  Prolog calls this "bagof"; I forget what Icon calls it.
+
+(define-syntax all-values
+  (syntax-rules ()
+    ((all-values x) (%all-values (lambda () x)))))
+
+(define (%all-values thunk)
+  (let ((results '()))
+    (either (let ((new-result (thunk)))
+	      (set! results (cons new-result results))
+	      (fail))
+	    (reverse results))))
+
+
+; Generate all the members of list l.  E.g.
+;   (all-values (+ (member-of '(10 20 30)) (member-of '(1 2 3))))
+;     => '(11 12 13 21 22 23 31 32 33)
+
+(define (member-of l)
+  (if (null? l)
+      (fail)
+      (either (car l) (member-of (cdr l)))))
+
+
+; Crufty initialization hack that allows you to type failing
+; expressions at the R-E-P loop (if there is an R-E-P loop).  E.g. try
+; evaluating the sequence
+;  (either 1 2)
+;  (fail)
+;  (+ (fail) 10)
+
+(define (init)
+  (set! *fail* #f)			;for GC purposes
+  (either 'initialized
+	  (let loop ()
+	    (either 'failed (loop)))))
+
+(display "Type (init) at the read-eval-print loop.")
+(newline)
diff --git a/scheme/misc/engine.scm b/scheme/misc/engine.scm
new file mode 100644
index 0000000..4a980c5
--- /dev/null
+++ b/scheme/misc/engine.scm
@@ -0,0 +1,70 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Christopher P. Haynes and Daniel P. Friedman.
+; Engines build process abstractions.
+; 1984 ACM Symposium on Lisp and Functional Programming, pages 18-24.
+
+; This is incompatible with the threads package.
+
+; ,open primitives interrupts
+
+(define interrupt/alarm (enum interrupt alarm))
+
+(define (run thunk interval when-done when-timeout)
+  (let ((save (vector-ref interrupt-handlers interrupt/alarm)))
+    (let ((finish
+	   (call-with-current-continuation
+	     (lambda (k)
+	       (vector-set! interrupt-handlers
+			    interrupt/alarm
+			    (lambda (tem ei)
+			      (set-enabled-interrupts! ei)
+			      (call-with-current-continuation
+				(lambda (resume)
+				  (k (lambda ()
+				       (when-timeout (lambda ()
+						       (resume #f)))))))))
+	       (schedule-interrupt interval *exponent* #f)
+	       (call-with-values thunk
+		 (lambda vals
+		   (let ((time-remaining (schedule-interrupt 0 0 #f)))
+		     (lambda ()
+		       (apply when-done time-remaining vals)))))))))
+      (vector-set! interrupt-handlers
+		   interrupt/alarm
+		   save)
+      (finish))))
+
+(define *exponent* -3)
+
+(define-syntax engine
+  (syntax-rules ()
+    ((engine ?E) (%engine (lambda () ?E)))))
+
+(define (%engine thunk)
+  (lambda (ticks done out)
+    (run thunk
+	 ticks
+	 (lambda (ticks val)
+	   (done val ticks))
+	 (lambda (new-thunk)
+	   (out (%engine new-thunk))))))
+
+
+; Example from the LFP '84 paper (verbatim)
+
+;(define-syntax rec
+;  (syntax-rules () ((rec ?X ?E) (letrec ((?X ?E)) ?X))))
+;
+;(define complete
+;  (lambda (eng)
+;    ((rec loop
+;       (lambda (eng count)
+;         (eng 1000
+;              (lambda (val ticks-left)
+;                (cons val
+;                      (+ (- 1000 ticks-left)
+;                         count)))
+;              (lambda (eng)
+;                (loop eng (+ count 1000))))))
+;     eng 0)))
diff --git a/scheme/misc/getenv.scm b/scheme/misc/getenv.scm
new file mode 100644
index 0000000..8d438ba
--- /dev/null
+++ b/scheme/misc/getenv.scm
@@ -0,0 +1,15 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; ,open primitives
+
+
+(define getenv
+  (let ((buffer (make-string 2000)))
+    (lambda (var-name)
+      (let ((len (vm-extension 26 (cons var-name buffer))))
+	(if len
+	    (substring buffer 0 len)
+	    #f)))))
+
+
diff --git a/scheme/misc/hilbert.scm b/scheme/misc/hilbert.scm
new file mode 100644
index 0000000..d470a3e
--- /dev/null
+++ b/scheme/misc/hilbert.scm
@@ -0,0 +1,107 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+;Date: Thu, 4 Nov 93 14:34:04 EST
+;Subject: binary search trees
+;From: kelsey@research.nj.nec.com
+;
+;If you want to add the Hilbert tables I think you should change
+;the name and add some documentation.  Neither the name nor the
+;only comment in the file are particulary informative.  They are
+;not infinite dimensional vectors, just arbitrarily large one
+;dimensional ones.
+;
+;How about make-big-vector etc.?
+
+
+; Hilbert vectors are like vectors that grow as large as they need to.
+; That is, they can be indexed by arbitrarily large nonnegative integers.
+
+; The implementation allows for arbitrarily large gaps by arranging
+; the entries in a tree.
+
+; So-called because they live in an infinite-dimensional vector
+; space...
+
+; ,open bitwise define-record-types
+
+
+(define hilbert-log 8)
+(define hilbert-node-size (arithmetic-shift 1 hilbert-log))
+(define hilbert-mask (- hilbert-node-size 1))
+(define minus-hilbert-log (- 0 hilbert-log))
+
+
+
+(define-record-type hilbert :hilbert
+  (really-make-hilbert height root)
+  (height hilbert-height set-hilbert-height!)
+  (root hilbert-root set-hilbert-root!))
+
+(define (make-hilbert)
+  (really-make-hilbert 1 (make-vector hilbert-node-size #f)))
+
+
+(define (hilbert-ref hilbert index)
+  (let recur ((height (hilbert-height hilbert))
+	      (index index))
+    (if (= height 1)
+	(let ((root (hilbert-root hilbert)))
+	  (if (< index (vector-length root))
+	      (vector-ref root index)
+	      #f))
+	(let ((node (recur (- height 1)
+			   (arithmetic-shift index minus-hilbert-log))))
+	  (if node
+	      (vector-ref node (bitwise-and index hilbert-mask))
+	      #f)))))
+	       
+(define (hilbert-set! hilbert index value)
+  (vector-set!
+   (let recur ((height (hilbert-height hilbert))
+	       (index index))
+     (if (= height 1)
+	 (make-higher-if-necessary hilbert index)
+	 (let ((index (arithmetic-shift index minus-hilbert-log)))
+	   (make-node-if-necessary
+	    (recur (- height 1) index)
+	    (bitwise-and index hilbert-mask)))))
+   (bitwise-and index hilbert-mask)
+   value))
+
+(define (make-higher-if-necessary hilbert index)
+  (if (< index hilbert-node-size)
+      (hilbert-root hilbert)
+      (let ((new-root (make-vector hilbert-node-size #f)))
+	(write `(higher ,index)) (newline)
+	(vector-set! new-root 0 (hilbert-root hilbert))
+	(set-hilbert-root! hilbert new-root)
+	(set-hilbert-height! hilbert (+ (hilbert-height hilbert) 1))
+	(let ((index (arithmetic-shift index minus-hilbert-log)))
+	  (make-node-if-necessary (make-higher-if-necessary hilbert index)
+				  (bitwise-and index hilbert-mask))))))
+
+(define (make-node-if-necessary node index)
+  (or (vector-ref node index)
+      (let ((new (make-vector hilbert-node-size #f)))
+	;; (write `(wider ,index)) (newline)
+	(vector-set! node index new)
+	new)))
+
+
+
+
+; For debugging
+;(define (hilbert->list h)
+;  (let recur ((node (hilbert-root h))
+;              (height (hilbert-height h))
+;              (more '()))
+;    (if (= height 0)
+;        (if (or node (pair? more))
+;            (cons node more)
+;            '())
+;        (do ((i (- hilbert-node-size 1) (- i 1))
+;             (more more (recur (if node
+;                                   (vector-ref node i)
+;                                   #f)
+;                               (- height 1) more)))
+;            ((< i 0) more)))))
diff --git a/scheme/misc/ilength.scm b/scheme/misc/ilength.scm
new file mode 100644
index 0000000..4008979
--- /dev/null
+++ b/scheme/misc/ilength.scm
@@ -0,0 +1,33 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Integer-length, a la Common Lisp, written in portable Scheme.
+
+(define-syntax cons-stream
+  (syntax-rules ()
+    ((cons-stream head tail)
+     (cons head (delay tail)))))
+(define head car)
+(define (tail s) (force (cdr s)))
+
+(define integer-length
+  (let ()
+    (define useful
+      (let loop ((p 256) (n 4))
+	(cons-stream (cons p n)
+		     (loop (* p p) (* n 2)))))
+    (define (recur n)
+      (if (< n 16)
+	  (vector-ref '#(0 1 2 2 3 3 3 3 4 4 4 4 4 4 4 4) n)
+	  (let loop ((s useful) (prev 16))
+	    (let ((z (head s)))
+	      (if (< n (car z))
+		  (+ (cdr z) (recur (quotient n prev)))
+		  (loop (tail s) (car z)))))))
+    (define (integer-length n)
+      (if (exact? n)
+	  (if (< n 0)
+	      (recur (- -1 n))
+	      (recur n))
+	  (integer-length (inexact->exact n))))
+    integer-length))
diff --git a/scheme/misc/integertostring.scm b/scheme/misc/integertostring.scm
new file mode 100644
index 0000000..19ae940
--- /dev/null
+++ b/scheme/misc/integertostring.scm
@@ -0,0 +1,66 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+;Date: Mon, 24 Jan 94 15:10:30 -0500
+;To: jar@ai.mit.edu
+;Subject: integer->string
+;From: kelsey@research.nj.nec.com
+;Sender: kelsey@research.nj.nec.com
+;
+;
+;I have gotten tired of waiting for bignums to print out.
+;Here is a somewhat more complex and faster version of integer->string.
+;
+;Converting 10**100 to a string:
+; Current:                    0.44 seconds
+; This:                       0.12 seconds
+; This using integer-divide:  0.06 seconds
+;
+;There is no overwhelming reason to use this, but here it is.
+
+
+(define integer->string
+  (let ()
+
+    (define (integer->string n radix)
+
+      (define (small-integer->magnitude n l)
+	(if (= n 0)
+	    l
+	    (small-integer->magnitude (quotient n radix)
+				      (cons (integer->digit (remainder n radix))
+					    l))))
+      
+      (define (integer->magnitude n)
+	(let ((rrrr (* (* radix radix) (* radix radix))))
+	  
+	  (let recur ((n n) (l '()))
+	       (if (< n rrrr)
+		   (small-integer->magnitude n l)
+		   (do ((i 4 (- i 1))
+			(n0 (remainder n rrrr) (quotient n0 radix))
+			(l l (cons (integer->digit (remainder n0 radix)) l)))
+		       ((= 0 i)
+			(recur (quotient n rrrr) l)))))))
+
+      (let ((magnitude (cond ((= n 0) '(#\0))
+			     ((< n 1000000)
+			      (small-integer->magnitude (abs n) '()))
+			     (else
+			      (integer->magnitude (abs n))))))
+	(list->string (if (>= n 0)
+			  magnitude
+			  (cons #\- magnitude)))))
+
+    (define (integer->digit n)
+      (ascii->char (+ n (if (< n 10)
+			    zero
+			    a-minus-10))))
+
+    (define zero (char->ascii #\0))
+    (define a-minus-10 (- (char->ascii #\a) 10))
+
+    integer->string))
+
+
+
diff --git a/scheme/misc/load-static.scm b/scheme/misc/load-static.scm
new file mode 100644
index 0000000..d07236b
--- /dev/null
+++ b/scheme/misc/load-static.scm
@@ -0,0 +1,42 @@
+; -*- Mode: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+;  ,exec ,load misc/load-static.scm
+;  (do-it 100000 "debug/little.image" "debug/little-heap.c")
+
+(translate "=scheme48/" "./")
+
+(config
+ (lambda ()
+   (load "vm/ps-interface.scm")
+   (load "vm/interfaces.scm")
+   (load "vm/package-defs.scm" "vm/s48-package-defs.scm")))
+
+(load-package 'bigbit)
+; The following is for struct's (for-syntax ...) clause
+; (load-package 'destructuring)
+
+(load-package 'heap)
+(in 'heap
+    (lambda ()
+      (run '(define (newspace-begin) *newspace-begin*))
+      (run '(define (heap-pointer) *hp*))
+      (structure 'heap-extra
+		 '(export newspace-begin
+			  heap-pointer
+			  header-a-units
+			  d-vector?
+			  stob-type))))
+
+(config '(run (define-structure static (export do-it)
+		(open scheme heap memory data stob struct
+		      heap-extra
+		      vm-architecture
+		      formats
+		      enumerated
+		      signals)
+		(files (misc static)))))
+
+(load-package 'static)
+(user '(open static))
+
diff --git a/scheme/misc/mail.scm b/scheme/misc/mail.scm
new file mode 100644
index 0000000..2e121df
--- /dev/null
+++ b/scheme/misc/mail.scm
@@ -0,0 +1,34 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+
+; Mailboxes (to be used with the threads package)
+
+(define (make-mailbox)
+  (vector (make-lock) (make-queue) (make-queue)))
+
+(define (mailbox-lock	  mbx) (vector-ref mbx 0))
+(define (mailbox-messages mbx) (vector-ref mbx 1))
+(define (mailbox-readers  mbx) (vector-ref mbx 2))
+
+(define (mailbox-empty? mbx)
+  (queue-empty? (mailbox-readers mbx)))
+
+(define (mailbox-write mbx message)
+  (with-lock (mailbox-lock mbx)
+    (lambda ()
+      (if (queue-empty? (mailbox-readers mbx))
+	  (enqueue! (mailbox-messages mbx) message)
+	  (condvar-set! (dequeue! (mailbox-readers mbx)) message)))))
+
+(define (mailbox-read mbx)
+  ((with-lock (mailbox-lock mbx)
+     (lambda ()
+       (if (queue-empty? (mailbox-messages mbx))
+	   (let ((cv (make-condvar)))
+	     (enqueue! (mailbox-readers mbx) cv)
+	     ;; The condvar-ref *must* happen after lock is released,
+	     ;; otherwise deadlock will result.
+	     (lambda () (condvar-ref cv)))
+	   (let ((message (dequeue! (mailbox-messages mbx))))
+	     (lambda () message)))))))
diff --git a/scheme/misc/packages.scm b/scheme/misc/packages.scm
new file mode 100644
index 0000000..db3e4df
--- /dev/null
+++ b/scheme/misc/packages.scm
@@ -0,0 +1,134 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Miscellaneous things.
+
+(define-structure reset/shift (export (reset :syntax)
+				      (shift :syntax))
+  (open scheme escapes signals)
+  (files shift-reset))
+
+(define-structure unix-system-calls
+    (export pipe waitpid fork dup close execv exit)
+  (open scheme externals signals)
+  (files syscall))
+
+(define-structure call-with-mumble-pipes
+    (export call-with-input-pipe call-with-output-pipe)
+  (open scheme
+	unix-system-calls
+	architecture channels
+	i/o-internal
+	signals)
+  (files pipe))
+
+(define-structure unix-getenv (export getenv)
+  (open scheme primitives)
+  (files getenv))
+
+(define-structure nondeterminism (export (either :syntax)
+					 (one-value :syntax)
+					 (all-values :syntax)
+					 fail
+					 init)
+  (open scheme)
+  (files either))
+
+(define-structure engines (export (engine :syntax))
+  (open scheme primitives interrupts)
+  (files engine))
+
+(define-structure remote (export remote-repl
+				 serve
+				 make-socket)
+  (open scheme
+	;; For server
+	closures
+	handle conditions
+	vm-exposure
+	;; For client
+	compiler
+	command-processor
+	interfaces
+ 	environments
+	;; For both?
+	packages
+	package-commands-internal
+	;; packages-internal ?
+	syntactic
+	built-in-structures
+	dump/restore
+	sockets
+	signals features)
+  (files remote))
+
+(define-structure requirements (export (require :syntax))
+  (open scheme-level-2
+	packages
+	environments
+	ensures-loaded
+	package-commands-internal
+	signals)
+  (files require))
+
+
+; Procedure annotations
+
+(define-structure annotations
+    (export annotate-procedure procedure-annotation)
+  (open scheme-level-1 assembler)
+  (files annotate))
+
+
+; DOODL
+
+(define-structure doodl doodl-interface
+  (open scheme
+	methods
+	meta-methods
+	annotations
+	define-record-types
+	records
+	;; handle	; ignore-errors
+	;; conditions	; error?
+	util 
+	signals)
+  (files doodl))
+
+
+(define-interface doodl-interface
+  (export ((method
+	    define-class
+	    define-method
+	    define-generic-function
+	    define-class
+	    set)
+	   :syntax)
+	  <function>
+	  <generic-function>
+	  <method>
+	  <class>
+
+	  <object>
+	  <number>
+	  <complex>
+	  <real>
+	  <rational>
+	  <integer>
+	  <pair>
+	  <symbol>
+	  <char>
+	  <null>
+	  <vector>
+	  <string>
+	  <eof-object>
+	  <input-port>
+	  <output-port>
+
+	  <list>    ;foo
+	  make
+	  initialize
+	  car-setter cdr-setter vector-ref-setter
+	  id?
+	  (bind :syntax)
+	  ;; etc. etc.
+	  ))
diff --git a/scheme/misc/pipe.scm b/scheme/misc/pipe.scm
new file mode 100644
index 0000000..78589be
--- /dev/null
+++ b/scheme/misc/pipe.scm
@@ -0,0 +1,51 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Scheme analogues of Posix popen() and pclose() library calls.
+
+(define (call-with-mumble-pipe input?)
+  (lambda (command proc)
+    (call-with-values pipe
+      (lambda (pipe-for-read pipe-for-write)
+	(let ((winner (if input? pipe-for-read pipe-for-write))
+	      (loser  (if input? pipe-for-write pipe-for-read))
+	      (pid (fork)))
+	  (if (= pid 0)
+	      (dynamic-wind
+	        (lambda () #f)
+		(lambda ()
+		  (close winner)
+		  (let ((foo (if input? 1 0)))
+		    (close foo)
+		    (if (not (= (dup loser) foo))
+			(error "dup lost" loser foo)))
+		  (execv "/bin/sh"
+			 (vector "sh" "-c" command)))
+		(lambda () (exit 1))))
+	  ;; (write `(pid = ,pid)) (newline)
+	  (close loser)
+	  (let* ((channel (open-channel winner
+					(if input?
+					    (enum open-channel-option
+						  raw-input-channel)
+					    (enum open-channel-option
+						  raw-output-channel))))
+		 (port (if input?
+			   (input-channel->port channel 1024)
+			   (output-channel->port channel 1024))))
+	    (call-with-values (lambda () (proc port))
+	      (lambda vals
+		(if input?
+		    (close-input-port port)
+		    (close-output-port port))
+		;; (display "Waiting.") (newline)
+		(call-with-values (lambda () (waitpid pid 0))
+		  (lambda (pid status)
+		    ;; (write `(status = ,status)) (newline)
+		    (apply values vals)))))))))))
+
+(define call-with-input-pipe
+  (call-with-mumble-pipe #t))
+
+(define call-with-output-pipe
+  (call-with-mumble-pipe #f))
+
diff --git a/scheme/misc/psd-s48.scm b/scheme/misc/psd-s48.scm
new file mode 100644
index 0000000..a945b57
--- /dev/null
+++ b/scheme/misc/psd-s48.scm
@@ -0,0 +1,129 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; To use PSD with Scheme 48:
+;  - Put (setq psd-using-slib nil) in your .emacs
+;  - Put this file in psd-directory
+;  - Remove (define *psd-tab-char* (integer->char 9)) from psd's read.scm
+;  - Do something horrible to primitives.scm to circumvent bug in
+;    Scheme 48's byte code compiler... those big long lists have to be
+;    split up: `((x ,x) ... (y ,y) ...) =>
+;     (let ((foo (lambda () `((x ,x) ...)))
+;	    (bar (lambda () `((y ,y) ...))))
+;	(append (foo) (bar)))
+
+; JAR's remarks:
+;   - The variable *PSD-PREVIOUS-LINE* was undefined (not consequentially so)
+;   - It doesn't support DELAY
+;   - It doesn't support the => syntax in COND
+;   - It doesn't like (write-char c port):
+;     ERROR: Wrong number of arguments to primitive procedure
+;     write-char
+;   - It would be awfully nice if there were a "quit" command
+;   - It leaves that little "=>" arrow in my buffer (except it's not
+;     really there, is it?)
+;   - It opens the source file multiple (maybe 6) times without
+;     closing it (not really a problem since the GC cleans these up, but
+;     sort of annoying)
+
+;;;;
+;;;; $Id: psd-s48.scm,v 1.1 1999/09/14 12:44:57 marting Exp $
+;;;;
+;;;; psd -- a portable Scheme debugger, version 1.1
+;;;; Copyright (C) 1992 Pertti Kellomaki, pk@cs.tut.fi
+
+;;;; This program 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 1, or (at your option)
+;;;; any later version.
+
+;;;; This program 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 this program; if not, write to the Free Software
+;;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+;;;; See file COPYING in the psd distribution.
+;;;;
+;;;;  $Log: psd-s48.scm,v $
+;;;;  Revision 1.1  1999/09/14 12:44:57  marting
+;;;;  *** empty log message ***
+;;;;
+;;;; Revision 1.6  1993/10/07  08:20:14  pk
+;;;; Define force-output, redefinition hurts less than getting an error
+;;;; message about nonexistent procedure.
+;;;;
+;;;; Revision 1.5  1993/10/06  13:06:16  pk
+;;;; Removed references to slib. Commented out force-output, let the user
+;;;; uncomment it if needed.
+;;;;
+;;;; Revision 1.4  1993/09/29  08:45:11  pk
+;;;; Removed reference to long and deep lists.
+;;;;
+;;;; Revision 1.3  1993/09/24  08:01:18  pk
+;;;; Changed version number from 1.0 to 1.1.
+;;;; Added loading of version.scm and announcing of version.
+;;;;
+;;;; Revision 1.2  1993/09/23  06:50:00  pk
+;;;; Moved definition of the Scheme variable psd-directory from the psd*.scm
+;;;; files to psd.el, which sends it to the Scheme process. This way, the path
+;;;; to psd needs to be specified only once.
+;;;;
+;;;; Revision 1.1  1993/09/22  12:45:32  pk
+;;;; Initial revision
+;;;;
+;;;;  
+
+;;;; 
+;;;; Written by Pertti Kellomaki, pk@cs.tut.fi
+;;;;
+;;;; SLIB interface to load psd files.
+
+;;;; This is the file that takes care of loading psd into the Scheme
+;;;; interpreter. If you want to modify psd to work with a particular
+;;;; implementation, say "foo", this is the way to do it:
+
+;;;; 1) Make a copy of the file "psd.scm" under the name "psd-foo.scm",
+;;;;    and modify it to load "primitives-foo.scm" instead of
+;;;;    "primitives.scm". You can also do other things.
+;;;;
+;;;; 2) Make a copy of the file "primitives.scm" under the name
+;;;;    "primitives-foo.scm", and modify the definitions in it to
+;;;;    know about the additional primitives in your implementation
+;;;;
+;;;; 3) When you now set the Emacs variable scheme-program-name to
+;;;;    "foo" and give the commands ``M-x run-scheme'' ``M-x psd-mode'',
+;;;;    you have a psd system that knows about your additional
+;;;;    primitives.
+
+;;; this is not portable.
+(define psd:control-z ((access-scheme-48 'ascii->char) 26))
+
+; Neither is this.
+(define *psd-tab-char* ((access-scheme-48 'ascii->char) 9))
+
+;;; FORCE-OUTPUT flushes any pending output on optional arg output port
+;;; use this definition if your system doesn't have such a procedure.
+(define (force-output . arg)
+  ((access-scheme-48 'force-output)
+   (if (null? arg) (current-output-port) (car arg))))
+
+(load (string-append psd-directory "qp.scm"))
+(load (string-append psd-directory "version.scm"))
+(load (string-append psd-directory "instrum.scm"))
+(load (string-append psd-directory "pexpr.scm"))
+(load (string-append psd-directory "read.scm"))
+(load (string-append psd-directory "runtime.scm"))
+(load (string-append psd-directory "primitives.scm"))
+
+(define *psd-previous-line* #f)
+
+;;;
+;;; Say hello
+;;;
+
+(psd-announce-version)
+
+(define error (access-scheme-48 'error))
diff --git a/scheme/misc/remote.scm b/scheme/misc/remote.scm
new file mode 100644
index 0000000..63e82da
--- /dev/null
+++ b/scheme/misc/remote.scm
@@ -0,0 +1,148 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This is a small mock-up of the Cornell mobile robot system.
+; It is not intended as a remote procedure call mechanism.
+
+; ,load-config =scheme48/misc/packages.scm
+; ,open remote
+
+; To start a server, do
+;   (define sock (make-socket))
+;   (serve sock)
+; To start a client, do
+;   (remote-repl "hostname" <number>)
+; where <number> is the number displayed by the server when it starts up.
+
+
+; Server side
+
+(define (note-structure-locations! s)
+  (define (recur name env trail)
+    (let ((b (generic-lookup env name)))
+      (if (binding? b)
+	  (begin
+	    (note-location! (binding-place b))
+	    (let ((t (binding-static b)))
+	      (if (and (transform? t) (not (member t trail)))
+		  (let ((trail (cons t trail))
+			(env (transform-env t)))
+		    (for-each (lambda (name)
+				(recur name env trail))
+			      (transform-aux-names (binding-static b))))))))))
+  (for-each-declaration (lambda (name type)
+			  (recur name s '())) 
+			(structure-interface s)))
+
+(note-structure-locations! scheme-level-2)
+
+(define (make-socket)
+  (call-with-values socket-server cons))
+
+(define (serve sock)
+  (let ((port-number (car sock))
+	(accept (cdr sock)))
+    (display "Port number is ")
+    (write port-number)
+    (newline)
+    (let ((in #f)
+	  (out #f))
+      (dynamic-wind (lambda ()
+		      (call-with-values accept
+			(lambda (i-port o-port)
+			  (display "Open") (newline)
+			  (set! in i-port)
+			  (set! out o-port))))
+		    (lambda ()
+		      (start-server in out))
+		    (lambda ()
+		      (if in (close-input-port in))
+		      (if out (close-output-port out)))))))
+
+(define (start-server in out)
+  (let loop ()
+    (let ((message (restore-carefully in)))
+      (case (car message)
+	((run)
+	 (dump (run-carefully (cdr message))
+	       (lambda (c) (write-char c out))
+	       -1)
+	 (force-output out)
+	 (loop))
+	((eof) (cdr message))
+	(else (error "unrecognized message" message))))))
+
+(define (run-carefully template)
+  (call-with-current-continuation
+    (lambda (escape)
+      (with-handler
+	  (lambda (c punt)
+	    (if (error? c)
+		(escape (cons 'condition c))
+		(punt)))
+	(lambda ()
+	  (call-with-values (lambda ()
+			      (invoke-closure (make-closure template #f)))
+	    (lambda vals
+	      (cons 'values vals))))))))
+
+
+; Client side
+
+(define (make-remote-eval in out)
+  (lambda (form p)
+    (compile-and-run-forms (list form)
+			   p
+			   #f
+			   (lambda (template)
+			     (dump (cons 'run template)
+				   (lambda (c) (write-char c out))
+				   -1)
+			     (force-output out)
+			     (let ((reply (restore-carefully in)))
+			       (case (car reply)
+				 ((values)
+				  (apply values (cdr reply)))
+				 ((condition)
+				  (signal-condition (cdr reply)))
+				 ((eof)
+				  (error "eof on connection")))))
+			   #f)))
+
+
+(define (make-remote-package in out opens id)
+  (let ((p (make-simple-package opens
+ 				#t
+ 				(reflective-tower
+ 				 (package->environment (interaction-environment)))
+ 				id)))
+    (set-package-evaluator! p (make-remote-eval in out))
+    p))
+
+(define (remote-repl host-name socket-port-number)
+  (let ((in #f) (out #f))
+    (dynamic-wind
+     (lambda ()
+       (call-with-values (lambda ()
+			   (socket-client host-name socket-port-number))
+	 (lambda (i-port o-port)
+	   (set! in i-port)
+	   (set! out o-port))))
+     (lambda ()
+       (with-interaction-environment (make-remote-package in out (list scheme) 'remote)
+				     (lambda () (command-loop list #f))))
+     (lambda ()
+       (if in (close-input-port in))
+       (if out (close-output-port out))))))
+
+
+; Common auxiliary
+
+(define (restore-carefully in)
+  (call-with-current-continuation
+    (lambda (exit)
+      (restore (lambda ()
+		 (let ((c (read-char in)))
+		   (if (eof-object? c)
+		       (exit (cons 'eof c))
+		       c)))))))
diff --git a/scheme/misc/require.scm b/scheme/misc/require.scm
new file mode 100644
index 0000000..3737a22
--- /dev/null
+++ b/scheme/misc/require.scm
@@ -0,0 +1,40 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+
+(define-syntax require
+  (syntax-rules (quote)
+    ((require '(name1 name2 ...))
+     (*require '(name1 name2 ...)))))
+
+(define (*require interface-id)
+  (let ((start-thunk
+	 (case (car interface-id)
+	   ((scheme-48)
+	    (let ((p (config-package)))
+	      (lambda () p)))
+	   ((scheme-library-1)
+	    (let* ((p (config-package))
+		   (thunk
+		    (lambda ()
+		      (environment-ref p 'scheme-library-1))))
+	      (ensure-loaded (thunk))
+	      (thunk)))
+	   (else
+	    (error "unrecognized interface identifier" interface-id)))))
+    (package-open! (interaction-environment)
+		   (let loop ((names (cdr interface-id))
+			      (thunk start-thunk))
+		     (if (null? names)
+			 thunk
+			 (let ((new-thunk 
+				(lambda ()
+				  (let ((source (thunk)))
+				    (if (package? source)
+					(environment-ref source
+							 (car names))
+					(*structure-ref source
+							(car names)))))))
+			   (ensure-loaded (new-thunk))
+			   (loop (cdr names)
+				 new-thunk)))))))
diff --git a/scheme/misc/separate.scm b/scheme/misc/separate.scm
new file mode 100644
index 0000000..566f6f9
--- /dev/null
+++ b/scheme/misc/separate.scm
@@ -0,0 +1,140 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+;  packages packages-internal scan compiler table
+;  syntactic vm-exposure signals locations fluids template
+;  closures types inline dump/restore
+;  environments
+
+; Separate compilation
+
+; Setting the get-location method isn't sufficient because it won't
+; intercept locations in already existing structures (e.g. scheme)...
+;
+;   cf. compile-structures in link.scm
+
+; Hacking the environment lookup mechanism to modify bindings on the
+; way out won't work, because it might cause denotation comparison to
+; fail during macro expansion...
+
+; So I think the best we can do is to maintain a location -> reference map.
+; There may be many routes to any particular location, but we'll only
+; be able to remember one of them.
+; (Actually, we _could_ remember all of them and then check at load time to
+; make sure that they all agree.)
+
+; The filtered environment also ought to be passed to the scanner,
+; because it caches looked-up bindings in nodes.  The effect of not
+; doing this is to get warning at compile time, and unbound variables
+; at load time.
+
+
+(define (compile-package-to-file p filename)
+  (let* ((table (make-table location-id))
+	 (env (package->separate p table))
+	 (stuff (scan-package p env))
+	 (templates '()))
+    (for-each (lambda (filename+nodes)
+		(set! templates
+		      (cons (compile-scanned-forms
+			     (cdr filename+nodes)
+			     p
+			     (car filename+nodes)
+			     (current-output-port)
+			     env)
+			    templates)))
+	      stuff)
+    (call-with-output-file filename
+      (lambda (port)
+	(fasdump (reverse templates) p table port)))))
+
+(define (package->separate p table)
+  (let ((cenv (package->environment p)))
+    (lambda (name)
+      (let ((probe (cenv name)))
+        (if (and (pair? probe)
+		 (location? (cdr probe))
+		 (not (table-ref table (cdr probe))))
+	    (table-set! table
+			(cdr probe)
+			(cons (name->qualified name)
+			      (let ((type (binding-type probe)))
+				(if (equal? type usual-variable-type)
+				    #f
+				    type)))))
+	probe))))
+
+(define *level* 0)
+
+(define (fasdump templates p table port)
+  (let* ((write-char (lambda (c)
+		       (write-char c port)))
+	 (dump (lambda (thing)
+		 (dump thing write-char -1))))
+    (dump *level*)
+    (dump (map structure-name (package-opens p)))  ;lose
+    (dump (map car (package-accesses p)))
+    (table-walk (lambda (loc qname+type)
+		  (dump (location-id loc))
+		  (dump qname+type))
+		table)
+    (dump '-)
+    (let-fluid $dump-index (lambda (loc)
+			     (if (table-ref table loc)
+				 (location-id loc)
+				 (begin (warn "lose" loc) #f)))
+      (lambda ()
+	(dump templates)))))
+
+(define (fasload filename name->structure)
+  (call-with-input-file filename
+    (lambda (port)
+      (let* ((read-char (lambda () (read-char port)))
+	     (restore (lambda () (restore read-char)))
+	     (table (make-table))
+	     (level (restore)))
+	(if (not (equal? level *level*))
+	    (warn "format revision level disagreement - try recompiling"
+		  `(file: ,level current: ,*level*)))
+	(let* ((open-names (restore))
+	       (access-names (restore))
+	       (p (make-package (lambda () (map name->structure open-names))
+				(lambda ()
+				  (map (lambda (name)
+					 (cons name
+					       (name->structure name)))
+				       access-names))
+				#f #f filename '()
+				#f	;uid
+				#f)))	;name
+	  (let loop ()
+	    (let ((uid (restore)))
+	      (if (not (eq? uid '-))
+		  (let ((qname+type (restore)))
+		    (table-set! table uid (reference->location qname+type p))
+		    (loop)))))
+	  (let-fluid $restore-index (lambda (id define?)
+				      (table-ref table id))
+	    (lambda ()
+	      (let ((templates (restore)))
+		(for-each (lambda (template)
+			    (if (not (template? template))
+				(error "lossage" template))
+			    (invoke-closure (make-closure template
+							  (package-uid p))))
+			  templates))))
+	  p)))))
+
+
+(define (reference->location qname+type p)
+  (let* ((compile-time-type (or (cdr qname+type) usual-variable-type))
+	 (name (qualified->name (car qname+type) p))
+	 (binding (package-lookup p name)))
+    (if (pair? binding)
+	(let ((type (binding-type binding)))
+	  (if (not (equal? type compile-time-type))
+	      (warn "type inconsistency" 
+		    `(compile time: ,compile-time-type)
+		    `(load time: ,type)))
+	  (cdr binding))
+	(package-define! p name compile-time-type))))
diff --git a/scheme/misc/shift-reset.scm b/scheme/misc/shift-reset.scm
new file mode 100644
index 0000000..48120b2
--- /dev/null
+++ b/scheme/misc/shift-reset.scm
@@ -0,0 +1,155 @@
+; no copyright notice
+
+; ,open signals escapes
+
+; Changes by jar:
+;   Added Uses of Scheme 48's WITH-CONTINUATION primitive, so that unreachable
+;   continuations can be reclaimed by the GC.
+;
+;   Renamed reset-thunk -> *reset
+;	    call/ct -> *shift
+;
+; Note: the meta-continuation ought to be thread-specific.
+; Alternatively, the threads package could be defined in terms of
+; shift and reset.  This would have the advantage of making the threads
+; package itself re-entrant.  It would be nice to rehabilitate the
+; runnable-threads queue, currently a piece of global state, as local
+; to a particular invocation of WITH-MULTITASKING.
+
+;Date: Wed, 29 Dec 1993 13:54:52 +0100
+;From: Olivier Danvy <danvy@daimi.aau.dk>
+;To: jar@martigny.ai.mit.edu
+;Subject: little Christmas gift
+;Reply-To: danvy@daimi.aau.dk
+;
+;Hi again:
+;
+;Here is a contribution for the Scheme48 library: the shift and reset
+;operators from "Abstracting Control" (LFP90) and "Representing Control"
+;(MSCS92).  In his POPL94 paper, Andrzej Filinski observed that since the
+;meta-continuation is single-threaded, it can be globalized in a
+;register.  Andrzej has programmed this both in SML and in Scheme.  I
+;only have prettified the Scheme definition a wee bit.
+
+(define-syntax reset
+  (syntax-rules ()
+    ((_ ?e) (*reset (lambda () ?e)))))
+
+(define-syntax shift
+  (syntax-rules ()
+    ((_ ?k ?e) (*shift (lambda (?k) ?e)))))
+
+(define *meta-continuation*
+  (lambda (v)
+    (error "You forgot the top-level reset...")))
+
+(define *abort
+  (lambda (thunk)
+    (with-continuation null-continuation ;JAR hack
+      (lambda ()
+	(let ((val (thunk)))
+	  (*meta-continuation* val))))))
+
+(define null-continuation #f)
+
+(define *reset
+  (lambda (thunk)
+    (let ((mc *meta-continuation*))
+      (call-with-current-continuation
+        (lambda (k)
+	  (begin
+	    (set! *meta-continuation*
+		  (lambda (v)
+		    (set! *meta-continuation* mc)
+		    (k v)))
+	    (*abort thunk)))))))
+
+(define *shift
+  (lambda (f)
+    (call-with-current-continuation
+      (lambda (k)
+	(*abort (lambda ()
+		  (f (lambda (v)
+		       (reset (k v))))))))))
+
+;----------
+;
+;Reminder: reset specifies a control delimiter.  shift grabs the current
+;continuation up to the current control delimiter, and reifies it as a
+;composable procedure.  If the procedure is not used, shift has the
+;effect of aborting up to the current control delimiter.
+;
+;Examples:
+;
+;(+ 10 (reset (+ 2 3)))
+;-->
+;15
+;
+;(+ 10 (reset (+ 2 (shift k 3))))
+;-->
+;13
+;
+;(+ 10 (reset (+ 2 (shift k (k 3)))))
+;-->
+;15
+;
+;(+ 10 (reset (+ 2 (shift k (+ 100 (k 3))))))
+;-->
+;115
+;
+;(+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3)))))))
+;-->
+;117
+;
+;
+;Other reminder: shift and reset are weaker than Matthias's control and
+;prompt, in that they can be CPS-transformed.
+;
+;Have a happy holiday,
+;
+;-- Olivier
+;
+;PS: This definition is not unlike David Espinoza's implementation of monadic
+;effects, ie, it has no interpretive or translation overhead.
+
+
+
+; JAR's notes:
+;
+;  ; CWCC defined in terms of SHIFT
+;
+;  (define cwcc
+;    (lambda (p)
+;      (shift k (k (p (lambda (x)
+;                       (shift k1 (k x))))))))
+;
+;  ; Monads from shift and reset (from Filinski, POPL '94)
+;
+;  (define (reflect meaning)
+;    (shift k (extend k meaning)))
+;
+;  (define (reify thunk)
+;    (reset (eta (thunk))))
+;
+;  Example: nondeterminism monad.
+;
+;  > (define (eta x) (list x))
+;  > (define (extend f l) (apply append (map f l)))
+;  > 
+;  > (define-syntax amb
+;      (syntax-rules () ((amb ?x ?y) (*amb (lambda () ?x) (lambda () ?y)))))
+;
+;  > (define (*amb t1 t2)
+;      (reflect (append (reify t1) (reify t2))))
+;  > 
+;  > (reify (lambda () (amb 1 2)))
+;  '(1 2)
+;  > (reify (lambda () (+ (amb 1 2) 3)))
+;  '(4 5)
+;  > 
+;  > (define cwcc call-with-current-continuation)
+;  > (reify (lambda ()
+;             (+ 1 (cwcc (lambda (k)
+;                          (* 10 (amb 3 (k 4))))))))
+;  '(31 51)
+;  > 
diff --git a/scheme/misc/sicp.scm b/scheme/misc/sicp.scm
new file mode 100644
index 0000000..38eb1b1
--- /dev/null
+++ b/scheme/misc/sicp.scm
@@ -0,0 +1,112 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Compatibility mode for use with Abelson & Sussman's book,
+; Structure and Interpretation of Computer Programs.
+
+; Requires ERROR, MAKE-TABLE, TABLE-REF, and TABLE-SET!.
+
+
+; Incompatible change to the meanings of AND and OR
+
+(define (and . rest)
+  (let loop ((rest rest))
+    (if (null? rest)
+	#t
+	(if (car rest)
+	    (loop (cdr rest))
+	    #f))))
+
+(define (or . rest)
+  (let loop ((rest rest))
+    (if (null? rest)
+	#f
+	(let ((temp (car rest)))
+	  (if temp
+	      temp
+	      (loop (cdr rest)))))))
+
+; Misc. nonsense
+
+(define-syntax sequence
+  (syntax-rules ()
+    ((sequence form ...) (begin form ...))))
+
+(define mapcar map)
+(define mapc for-each)
+
+(define (1+ x) (+ x 1))
+(define (-1+ x) (- x 1))
+
+(define t #t)
+(define nil #f)
+(define (atom? x) (not (pair? x)))
+
+(define (print x)
+  (write x)
+  (newline))
+(define princ display)
+(define prin1 write)
+
+; Streams
+
+(define-syntax cons-stream
+  (syntax-rules ()
+    ((cons-stream head tail)
+     (cons head (delay tail)))))
+
+(define head car)
+(define (tail s) (force (cdr s)))
+(define the-empty-stream '<the-empty-stream>)
+(define (empty-stream? s) (eq? s the-empty-stream))
+
+; EXPLODE and IMPLODE
+
+(define (explode thing)
+  (map (lambda (c) (string->symbol (string c)))
+       (string->list (cond ((symbol? thing)
+			    (symbol->string thing))
+			   ((number? thing)
+			    (number->string thing))
+			   (else
+			    (error "invalid argument to explode" thing))))))
+
+(define (implode l)
+  (string->symbol (list->string (map (lambda (s)
+				       (string-ref (symbol->string s) 0))
+				     l))))
+
+; GET and PUT
+
+(define (make-property-module)
+  (define symbol-properties-table #f)
+
+  (define (put symbol indicator value)
+    (let* ((probe (table-ref symbol-properties-table symbol))
+	   (table (if probe
+		      probe
+		      (let ((table (make-table)))
+			(table-set! symbol-properties-table symbol table)
+			table))))
+      (table-set! table indicator value)))
+
+  (define (get symbol indicator)
+    (let ((probe (table-ref symbol-properties-table symbol)))
+      (if probe
+	  (table-ref probe indicator)
+	  #f)))
+
+  (set! symbol-properties-table (make-table))
+
+  (cons get put))
+
+(define property-module (make-property-module))
+(define get (car property-module))
+(define put (cdr property-module))
+
+; Need these special forms:
+;   collect make-environment access the-environment
+
+; The following are among the procedures defined in MIT's student
+; system; I don't know how many are actually needed for the book:
+;   ascii char nth nthcdr tyo vector-cons
+;   accumulate filter map-stream append-streams
diff --git a/scheme/misc/static.scm b/scheme/misc/static.scm
new file mode 100644
index 0000000..c86c698
--- /dev/null
+++ b/scheme/misc/static.scm
@@ -0,0 +1,216 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This little utility converts a heap image into a C file.
+;
+; For example:
+;   (do-it 100000 "~/s48/debug/little.image" "little-heap.c")
+;
+; The first argument to do-it should be somewhat larger than the size,
+; in bytes, of the image file to be converted (which you can obtain with
+; "ls -l").
+;
+; If the image contains 0-length stored objects, then the .c file will
+; have to be compiled by gcc, since 0-length arrays aren't allowed in
+; ANSI C.  This wouldn't be difficult to work around.
+;
+; For loading instructions, see load-static.scm.
+
+(define *comments?* #f)
+
+; 800,000 bytes => 200,000 words => at least 100,000 objects
+;   50 chunks => 16,000 bytes per chunk => 2,000 objects per chunk
+(define *chunk-size* 10000)
+
+(define (do-it bytes infile outfile)
+  (let ((start (init bytes infile)))
+    (call-with-output-file outfile
+      (lambda (port)
+	(format port "#define D(x) (long)(&x)+7~%")
+	(format port "#define H unsigned long~%")
+	(emit-area-declarations "p" immutable? "const " port)
+	(emit-area-declarations "i" mutable? "" port)
+	(emit-area-initializers "p" immutable? "const " port)
+	(emit-area-initializers "i" mutable? "" port)
+	(display "const long entry = " port)
+	(emit-descriptor start port)
+	(write-char #\; port)
+	(newline port)))))
+
+(define (init bytes infile)
+  (create-memory (quotient bytes 2) quiescent) ;Output of ls -l
+  (initialize-heap (memory-begin) (memory-size))
+  (let ((start (read-image infile 0)))
+    (message (nchunks)
+	     " chunks")
+    start))
+
+(define (nchunks) (+ (chunk-number (heap-pointer)) 1))
+
+; emit struct declarations for areas
+
+(define (emit-area-declarations name in-area? const port)
+  (for-each-stored-object
+   (lambda (chunk)
+     (message name chunk " declaration")
+     (display "struct " port) (display name port) (display chunk port)
+     (display " {" port) (newline port))
+   (lambda (x)
+     (if (in-area? x)
+	 (emit-declaration x port)))
+   (lambda (chunk)
+     (display "};" port)
+     (newline port)
+     (display const port)
+     (display "extern struct " port) (display name port) (display chunk port)
+     (write-char #\space port) (display name port) (display chunk port)
+     (write-char #\; port) (newline port)
+     chunk)))
+
+(define (emit-declaration x port)
+  (display "  H x" port)
+  (writex x port)
+  (cond ((d-vector? x)
+	 (display "; long d" port)
+	 (writex x port)
+	 (write-char #\[ port)
+	 (write (d-vector-length x) port))
+	((vm-string? x)
+	 (display "; char d" port)
+	 (writex x port)
+	 (write-char #\[ port)
+	 ;; Ensure alignment (thanks Ian)
+	 (write (cells->bytes (bytes->cells (b-vector-length x)))
+		port))
+	(else
+	 (display "; unsigned char d" port)
+	 (writex x port)
+	 (write-char #\[ port)
+	 ;; Ensure alignment
+	 (write (cells->bytes (bytes->cells (b-vector-length x)))
+		port)))
+  (display "];" port)
+  (if *comments?*
+      (begin (display " /* " port)
+	     (display (enumerand->name (stob-type x) stob) port)
+	     (display " */" port)))
+  (newline port))
+
+; Emit initializers for areas
+
+(define (emit-area-initializers name in-area? const port)
+  (for-each-stored-object
+   (lambda (chunk)
+     (message name chunk " initializer")
+
+     (display const port)
+     (display "struct " port) (display name port) (write chunk port)
+     (write-char #\space port) (display name port) (write chunk port)
+     (display " =" port) (newline port)
+
+     (write-char #\{ port) (newline port))
+   (lambda (x)
+     (if (in-area? x)
+	 (emit-initializer x port)))
+   (lambda (chunk)
+     (display "};" port) (newline port)))
+
+  (let ((n (nchunks)))
+    (format port "const long ~a_count = ~s;~%" name n)
+    (format port "~a long * const ~a_areas[~s] = {" const name n)
+    (do ((i 0 (+ i 1)))
+	((= i n))
+      (format port "(~a long *)&~a~s, " const name i))
+    (format port "};~%const long ~a_sizes[~s] = {" name n)
+    (do ((i 0 (+ i 1)))
+	((= i n))
+      (format port "sizeof(~a~s), " name i))
+    (format port "};~%")))
+
+
+(define (message . stuff)
+  (for-each display stuff) (newline))
+
+(define (emit-initializer x port)
+  (display "  " port)
+  (write (stob-header x) port)
+  (write-char #\, port)
+  (cond ((d-vector? x)
+	 (emit-d-vector-initializer x port))
+	((vm-string? x)
+	 (write-char #\" port)
+	 (let ((len (vm-string-length x)))
+	   (do ((i 0 (+ i 1)))
+	       ((= i len) (write-char #\" port))
+	     (let ((c (vm-string-ref x i)))
+	       (cond ((or (char=? c #\") (char=? c #\\))
+		      (write-char #\\ port))
+		     ((char=? c #\newline)
+		      (display "\\n\\" port)))
+	       (write-char c port)))))
+	(else
+	 (write-char #\{ port)
+	 (let ((len (b-vector-length x)))
+	   (do ((i 0 (+ i 1)))
+	       ((= i len) (write-char #\} port))
+	     (write (b-vector-ref x i) port)
+	     (write-char #\, port)))))
+  (write-char #\, port)
+  (if *comments?*
+      (begin (display " /* " port)
+	     (writex x port)
+	     (display " */" port)))
+  (newline port))
+
+(define (emit-d-vector-initializer x port)
+  (write-char #\{ port)
+  (let ((len (d-vector-length x)))
+    (do ((i 0 (+ i 1)))
+	((= i len) (write-char #\} port))
+      (emit-descriptor (d-vector-ref x i) port)
+      (write-char #\, port))))
+
+(define (emit-descriptor x port)
+  (if (stob? x)
+      (begin (if (immutable? x)
+		 (display "D(p" port)
+		 (display "D(i" port))
+	     (display (chunk-number x) port)
+	     (display ".x" port)
+	     (writex x port)
+	     (write-char #\) port))
+      (write x port)))
+
+
+; Foo
+
+(define (writex x port)
+  (write (quotient (- (- x (memory-begin)) 7) 4) port))
+
+(define (chunk-number x)
+  (quotient (- (- x (memory-begin)) 7) *chunk-size*))
+
+
+; Image traversal utility
+
+(define (for-each-stored-object chunk-start proc chunk-end)
+  (let ((limit (heap-pointer)))
+    (let chunk-loop ((addr (newspace-begin))
+		     (i 0)
+		     (chunk (+ (newspace-begin) *chunk-size*)))
+      (if (addr< addr limit)
+	  (begin (chunk-start i)
+		 (let loop ((addr addr))
+		   (if (and (addr< addr limit)
+			    (addr< addr chunk))
+		       (let ((d (fetch addr)))
+			 (if (not (header? d))
+			     (warn "heap is in an inconsistent state" d))
+			 (proc (address->stob-descriptor (addr1+ addr)))
+			 (loop (addr1+ (addr+ addr (header-a-units d)))))
+		       (begin (chunk-end i)
+			      (chunk-loop addr
+					  (+ i 1)
+					  (+ chunk *chunk-size*))))))))))
+
+(define (mutable? x) (not (immutable? x)))
diff --git a/scheme/misc/syscall.scm b/scheme/misc/syscall.scm
new file mode 100644
index 0000000..adf23a2
--- /dev/null
+++ b/scheme/misc/syscall.scm
@@ -0,0 +1,93 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Some Unix system calls.  By no means all of them.
+; Cf. external.c
+
+(define pipe
+  (let ((s48_pipe (get-external "s48_pipe")))
+    (lambda ()
+      (let ((results (cons 0 0)))
+	(unix-system-call s48_pipe 'pipe results)
+	(values (car results) (cdr results))))))
+
+(define waitpid
+  (let ((s48_waitpid (get-external "s48_waitpid")))
+    (lambda (pid options)
+      (let ((results (cons 0 0)))
+	(unix-system-call s48_waitpid 'waitpid results pid options)
+	(values (car results) (cdr results))))))
+
+(define fork
+  (let ((s48_fork (get-external "s48_fork")))
+    (lambda ()
+      (let ((results (cons -2 #f)))
+	(unix-system-call s48_fork 'fork results)
+	(car results)))))
+
+(define dup
+  (let ((s48_dup (get-external "s48_dup")))
+    (lambda (fd)
+      (let ((result (cons 0 0)))
+	(unix-system-call s48_dup 'dup result fd)
+	(car result)))))
+
+(define close
+  (let ((s48_close (get-external "s48_close")))
+    (lambda (fd)
+      (unix-system-call s48_close 'close fd))))
+
+(define execv
+  (let ((s48_execv (get-external "s48_execv")))
+    (lambda (path argv)
+      (unix-system-call s48_execv 'execv path argv)
+      (error "execv returned?" path argv))))
+
+(define exit
+  (let ((s48_exit (get-external "s48_exit")))
+    (lambda args
+      (apply external-call s48_exit args)
+      (error "exit returned!?"))))
+
+
+; Utility
+
+(define (unix-system-call external id . args)
+  (let loop ()
+    (let ((errno (apply external-call external args)))
+      (if errno
+	  (if (= errno 4)		;EINTR
+	      (begin (warn "interrupted system call" id)
+		     (loop))
+	      (apply call-error (strerror errno) id args))
+	  #t))))
+
+; Utility for printing error messages
+
+(define strerror
+  (let ((s48_strerror (get-external "s48_strerror")))
+    (lambda (n)
+      (let* ((s (make-string 100))
+	     (l (external-call s48_strerror s n)))
+	(if (integer? l)
+	    (substring s 0 l)
+	    (call-error "miscellaneous error" strerror n))))))
+
+
+
+; To coerce a file descriptor to a channel:
+; ,open architecture channels
+;   (open-channel in-fd
+;		  (enum open-channel-option
+;			raw-input-channel))
+;   (open-channel out-fd
+;		  (enum open-channel-option
+;			raw-output-channel))
+
+; To coerce a channel to a port:
+; ,open i/o-internal
+;   (input-channel->port <channel> 1024) ; buffer size
+;   (output-channel->port <channel> 1024)
+; The inverse operation is not available.
+
+; To coerce a channel to a file descriptor:
+;   (vm-extension 30 channel) => fd
diff --git a/scheme/misc/test-doodl.scm b/scheme/misc/test-doodl.scm
new file mode 100644
index 0000000..97fe630
--- /dev/null
+++ b/scheme/misc/test-doodl.scm
@@ -0,0 +1,52 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; ((method () 1)) => 1
+; ((method () 1) 2) => error
+
+; ((method (x) 1) 2) => 1
+; ((method ((x <symbol>)) 1) 2) => error
+
+; ((method ((x <symbol>)) 1) 'foo) => 1
+; ((method ((x <symbol>)) (next-method)) 'foo) => error
+
+
+
+(define-generic-function elt ((s <sequence>)))
+
+(define-method elt ((x <vector>) y)
+  (vector-ref x y))
+
+; (elt '#(a b c) 1) => b
+
+(define-method elt ((x <string>) y)
+  (string-ref x y))
+
+(define-method elt ((x <list>) y)
+  (list-ref x y))
+
+
+; Setters
+
+(define-generic-function (setter elt)
+  (thing index new-value))
+
+(define-method (setter elt) ((x <vector>) i z)
+  (vector-set! x i z))
+
+; (let ((v (vector 1 2 3))) (set (elt v 1) 'foo) v) => '#(1 foo 3)
+
+
+; Classes
+
+(define-class <mumble> () a b)
+
+; (a (make <mumble>)) => '*uninitialized*
+; (let ((m (make <mumble>))) (set (a m) 'foo) (a m)) => 'foo
+
+(define-method initialize ((m <mumble>) z)
+  (set (a m) z))
+
+; (a (make <mumble> 3)) => 3
+
+
diff --git a/scheme/more-interfaces.scm b/scheme/more-interfaces.scm
new file mode 100644
index 0000000..8f9274b
--- /dev/null
+++ b/scheme/more-interfaces.scm
@@ -0,0 +1,384 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Interfaces for packages that can get loaded after the initial.image
+; starts up.
+
+; Command processor
+
+(define-interface command-processor-interface
+  (export $write-length $write-depth
+	  abort-to-command-level
+	  add-sentinel!
+	  command-continuation
+	  command-threads
+	  command-loop
+	  command-level-condition
+	  command-processor
+	  error-form ;foo
+	  execute-command
+	  exit-command-processor
+	  evaluate-and-select
+	  gobble-line
+	  greet-user
+	  environment-for-commands
+	  focus-object
+	  pop-command-level
+	  read-command			;take
+	  read-command-carefully	;inspect
+	  read-form
+	  run-sentinels
+	  set-focus-object!
+	  showing-focus-object		;inspect
+	  start-command-processor
+	  restart-command-processor
+	  value->expression		;foo
+	  write-carefully
+	  write-line
+	  y-or-n?
+	  help
+	  define-command-syntax
+          define-user-command-syntax
+	  user-command-environment
+	  ;; set-command-structure!        ;startup
+	  ;; command-structure             ;pacman
+          set-user-command-environment! ;pacman
+          read-command-error            ;inspect
+	  &environment-id-string
+	  ;&evaluate
+	  ))
+
+(define-interface command-levels-interface
+  (export start-command-levels
+	  command-levels
+	  top-command-level
+	  push-command-level
+	  throw-to-command-level
+	  restart-command-level
+	  proceed-with-command-level
+	  kill-paused-thread!
+
+	  user-context
+	  user-context-accessor
+	  user-context-modifier
+
+	  push-command-levels?
+
+	  command-input
+	  command-output
+	  command-error-output
+	  focus-values
+	  set-focus-values!
+	  batch-mode?
+	  set-batch-mode?!
+	  break-on-warnings?
+	  set-break-on-warnings?!
+
+	  reset-command-input?  ; condition predicate 
+
+	  repl-data set-repl-data!
+
+	  terminate-command-processor!
+	  command-level
+	  command-level-threads
+	  command-level-paused-thread
+	  command-level-repl-data
+	  command-level?))
+
+(define-interface basic-commands-interface
+  (export exit
+	  exit-when-done
+          go
+	  load
+          help
+          run
+	  ?))
+   
+(define-interface build-commands-interface
+  (export dump
+          build))
+       
+(define-interface inspect-commands-interface
+  (export inspect
+	  debug
+	  threads
+	  where))
+       
+(define-interface disassemble-commands-interface
+  (export dis))
+   
+(define-interface profile-commands-interface
+  (export profile))
+   
+(define-interface package-commands-interface
+  (export in
+	  new-package
+	  load-package
+	  reload-package
+	  structure
+	  open
+	  for-syntax
+	  exec
+	  user
+	  user-package-is
+	  config
+	  config-package-is
+	  undefine))
+
+(define-interface debug-commands-interface
+  (export translate
+	  preview
+	  proceed
+	  push
+	  pop
+          reset
+	  level
+	  condition
+	  batch
+	  bench
+	  break-on-warnings
+	  form-preferred
+	  levels
+	  flush
+	  keep
+          collect
+	  trace
+	  untrace
+	  time
+          from-file
+	  forget
+	  bound?
+	  expand))
+
+(define-interface usual-commands-interface
+  (compound-interface
+   basic-commands-interface
+   build-commands-interface
+   package-commands-interface
+   debug-commands-interface
+   inspect-commands-interface
+   disassemble-commands-interface
+   ;profile-commands-interface
+   ))
+
+(define-interface package-commands-internal-interface
+  (export config-package
+	  new-command-processor
+	  get-structure
+	  ;get-package
+	  ;set-package-evaluator!
+	  ))
+
+(define-interface debuginfo-interface
+  (export read-debug-info
+	  write-debug-info))
+
+(define-interface disclosers-interface
+  (export make-print-name
+	  template-file-name
+	  value->expression
+	  error-form
+	  location-info
+	  location-name
+	  template-debug-data
+	  template-id
+	  template-name
+	  template-names
+	  debug-data-names))
+
+(define-interface package-mutation-interface
+  (export package-system-sentinel	;env/command.scm
+	  package-open!			;env/debug.scm
+	  package-undefine!
+	  ))
+
+(define-interface packages-cruft-interface
+  (export assume-denotation
+	  ;; new-location-uid    ;?
+	  interface-ref
+	  structure-interface
+	  verify-package		;for debugging the package system
+	  ))
+
+
+; --------------------
+; Linker
+
+(define-interface linker-interface
+  (export link-simple-system
+	  link-reified-system
+	  link-semireified-system
+	  (struct-list :syntax)
+	  compile-structures))
+
+(define-interface expander-interface
+  (export expand-form
+	  expand-stuff
+	  expand
+	  usage-reference-count
+	  usage-operator-count
+	  usage-assignment-count
+	  free-top-level-variables))
+
+; --------------------
+; Extended numbers: bignums, ratnums, etc.
+
+(define-interface extended-numbers-interface
+  (export (define-extended-number-type :syntax)
+	  (define-opcode-extension :syntax)
+	  :exact :inexact
+	  string-position
+	  &+
+	  &-
+	  &*
+	  &/
+	  &=
+	  &<
+	  &quotient
+	  &remainder
+	  &integer?
+	  &rational?
+	  &real?
+	  &complex?
+	  &number?
+	  &exact?
+	  &exact->inexact
+	  &inexact->exact
+	  &real-part
+	  &imag-part
+	  &floor
+	  &numerator
+	  &denominator
+	  &exp &log
+	  &sin &cos &tan &asin &acos &atan
+	  &sqrt
+	  &make-rectangular
+	  &number->string
+	  &really-string->number))
+
+(define-interface bignums-interface  ;Things used by bigbit
+  (export integer->bignum bignum-magnitude bignum-sign
+	  zero-magnitude?
+	  integer->magnitude
+	  adjoin-digit
+	  low-digit high-digits
+	  make-integer
+	  zero-magnitude
+	  radix log-radix
+	  integer-negate integer- integer=))
+
+(define-interface time-interface
+  (export real-time
+	  run-time))
+
+; Experimental DEFINE-RECORD-TYPE that is now officially a failure.
+
+(define-interface defrecord-interface  ;RK's
+  (export (define-record-type :syntax)
+	  define-record-discloser))
+
+; --------------------
+; Big Scheme
+
+(define-interface dynamic-externals-interface
+  (export dynamic-load
+
+          get-external
+	  lookup-all-externals
+
+	  external?
+	  external-name
+	  external-value
+	  external-lookup
+
+	  call-external))
+
+(define-interface dump/restore-interface
+  (export dump
+	  restore
+	  note-location!
+	  $dump-index
+	  $restore-index))
+
+(define-interface extended-ports-interface
+  (export char-source->input-port
+	  char-sink->output-port
+	  make-tracking-input-port make-tracking-output-port
+	  make-string-input-port
+	  make-string-output-port
+	  string-output-port-output
+	  call-with-string-output-port		; denigrated
+	  write-one-line
+	  current-row current-column fresh-line))
+
+(define-interface arrays-interface
+  (export make-array		; <initial-value> <bound1> ...
+	  array?
+	  array-shape		; <array>
+	  array-ref		; <array> <index1> ...
+	  array-set!		; <array> <value> <index1> ...
+	  make-shared-array	; <array> <linear-map> <bound1> ...
+	  copy-array		; <array>
+	  array->vector		; <array>
+	  array))		; <bounds> . <elements>
+
+(define-interface search-trees-interface
+  (export make-search-tree
+	  search-tree?
+          search-tree-ref
+          search-tree-set!
+          search-tree-modify!
+          search-tree-max pop-search-tree-max!
+          search-tree-min pop-search-tree-min!
+          walk-search-tree))
+
+; This is getting to be a hodge-podge.
+
+(define-interface big-util-interface       
+  (export concatenate-symbol
+	  error breakpoint
+	  atom? null-list? neq? n=
+	  identity no-op
+	  memq? first any? any every?
+	  filter filter! filter-map partition-list partition-list!
+	  remove-duplicates delq delq! delete
+	  reverse!
+	  copy-string
+	  string->immutable-string
+	  ))
+
+(define-interface big-scheme-interface
+  (compound-interface
+      (interface-of ascii)
+      (interface-of bitwise)
+      (interface-of tables)
+      (interface-of enumerated)
+      ;defrecord-interface
+      extended-ports-interface
+      big-util-interface
+      (export (destructure :syntax)
+	      (receive :syntax)
+	      format
+	      p pretty-print
+	      sort-list sort-list!)))
+
+; --------------------
+; Miscellaneous
+
+; Copied from interfaces.scm.
+(define-interface define-record-types-interface
+  (export (define-record-type :syntax)
+	  define-record-discloser))
+
+(define-interface placeholder-interface
+  (export make-placeholder
+	  placeholder?
+	  placeholder-value
+	  placeholder-set!))
+
+(define-interface sicp-interface
+  (export and or (sequence :syntax)
+	  mapcar mapc 1+ -1+ t nil atom? print princ prin1 error
+	  (cons-stream :syntax) head tail the-empty-stream empty-stream?
+	  explode implode get put))
+
diff --git a/scheme/more-packages.scm b/scheme/more-packages.scm
new file mode 100644
index 0000000..b4d3be3
--- /dev/null
+++ b/scheme/more-packages.scm
@@ -0,0 +1,726 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; More and more packages.  Some of these get loaded into the initial
+; image to create scheme48.image; those that aren't can be loaded later
+; using ,load-package.
+
+
+; Things to load into initial.image to make scheme48.image.
+
+(define-structure usual-features (export )  ;No exports
+  (open analysis		;auto-integration
+	disclosers
+        command-processor
+        debuginfo
+        ;; Choose any combination of bignums, ratnums, recnums
+	bignums ratnums recnums
+	;; Choose either innums, floatnums, or neither
+	innums			;Silly inexact numbers
+        ;; floatnums		;Still don't print correctly
+	;; pp
+	;; The following is listed because this structure is used to
+	;; generate a dependency list used by the Makefile...
+	usual-commands))
+
+
+; Command processor
+
+(define-structures ((command-processor command-processor-interface)
+		    (command (export command-processor)))
+  (open scheme ;;-level-2     ; eval, interaction-environment
+	tables fluids
+	conditions handle
+	define-record-types
+	command-levels
+	reading			; gobble-line, with-sharp-sharp
+	i/o                     ; current-error-port
+	display-conditions	; display-condition
+	methods
+	;; environments		; interaction-environment
+	util			; unspecific
+	undefined		; $note-undefined
+	features		; force-output
+	interrupts		; set-enabled-interrupts!, all-interrupts
+	vm-exposure		; primitive-catch
+	fluids-internal         ; get-dynamic-env, set-dynamic-env!
+	nodes			; for ## kludge
+	signals
+	structure-refs
+	root-scheduler)		; scheme-exit-now
+  (access threads		; thread?
+	  threads-internal      ; thread-continuation
+	  continuations         ; continuation?
+	  ports)
+  (files (env version-info)
+	 (env command)
+	 (env read-command)))
+
+(define-structure command-levels command-levels-interface
+  (open scheme
+	enumerated enum-case 
+	tables
+	session-data
+	define-record-types
+	threads threads-internal
+	scheduler
+	interrupts
+	weak
+	debug-messages		; for debugging
+	signals			; error
+	i/o			; current-error-port
+	util                    ; unspecific
+	channel-i/o             ; steal-channel-port
+	fluids-internal         ; get-dynamic-env, set-dynamic-env!
+	root-scheduler          ; call-when-deadlocked!
+	conditions)             ; define-condition-type
+  (files (env command-level)))
+
+(define-structure basic-commands basic-commands-interface
+  (open scheme-level-2
+        command-processor
+	command-levels
+        undefined               ; noting-undefined-variables
+	environments		; with-interaction-environment
+	evaluation		; eval, load-into
+        ;; packages		; package?
+	root-scheduler		; scheme-exit-now
+	)
+  (files (env basic-command)))
+
+; Usual command set
+               
+(define-structure usual-commands usual-commands-interface
+  (open basic-commands
+        build-commands
+        package-commands
+        debug-commands
+        inspect-commands
+        disassemble-commands
+	;profile-commands
+	))
+
+; Image builder.
+
+(define-structures ((build (export build-image stand-alone-resumer))
+		    (build-commands build-commands-interface))
+  (open scheme-level-2
+        command-processor
+	command-levels
+        conditions handle
+        low-level               ; flush-the-symbol-tables!
+        usual-resumer
+        filenames               ; translate
+        display-conditions      ; display-condition
+        evaluation              ; package-for-load, eval
+	environments		; with-interaction-environment
+	i/o			; current-error-port
+        write-images
+        signals)
+  (files (env build)))
+
+; Package commands.
+
+(define-structures ((package-commands package-commands-interface)
+		    (package-commands-internal
+		       package-commands-internal-interface))
+  (open scheme
+        command-processor
+	command-levels
+	methods
+        undefined               ; noting-undefined-variables
+        packages                ; for creating a user package
+        packages-internal       ; set-package-integrate?!, etc.
+        package-mutation        ; package-system-sentinel
+        environments            ; *structure-ref, etc.
+	compiler-envs		; reflective-tower
+        ensures-loaded          ; ensure-loaded
+	interfaces
+	ascii
+	i/o			; force-output, current-error-port
+        signals
+	util			; every
+        fluids)
+  (files (env pacman)))
+
+
+; Debugging aids.
+
+; Disclosers: this makes objects and conditions print nicely.
+
+(define-structure disclosers disclosers-interface
+  (open scheme-level-1
+        methods more-types
+        tables
+        conditions
+        display-conditions
+        locations
+        code-vectors
+        closures
+        packages-internal       ; location-info-tables
+        debug-data
+	segments                ; get-debug-data
+        enumerated              ; enumerand->name
+        weak                    ; weak-pointer?
+	i/o                     ; disclose-port
+        templates continuations low-channels
+        architecture)
+  (files (env disclosers)))
+
+; For printing procedures with their names, etc.
+
+(define-structure debuginfo debuginfo-interface
+  (open scheme-level-2
+        tables
+        debug-data
+	segments		; debug-data-table
+        ;; packages
+        packages-internal	; package-name-table
+        names			; generated?
+	features
+	weak)
+  (files (env debuginfo)))
+
+; Most of the debugging commands.
+
+(define-structures ((debugging		;additional exports in future
+		     (export breakpoint
+			     continuation-parent))
+		    (debug-commands debug-commands-interface))
+  (open scheme-level-2
+        command-processor       ; define-command, etc.
+	command-levels
+        fluids
+        signals                 ; make-condition
+        util                    ; filter
+        evaluation              ; eval-from-file, eval
+        environments            ; environment-define! (for ,trace)
+        conditions              ; define-condition-type
+        filenames               ; set-translation!
+        disclosers              ; template-name, debug-data-names
+        packages                ; flush-location-names, package-integrate?
+        packages-internal       ; [set-]package-integrate?[!], flush-location-names
+	undefined		; noting-undefined-variables
+        continuations           ; continuation-template
+        architecture            ; op/global, etc.
+        interrupts              ; all-interrupts, set-enabled-interrupts!
+        vm-exposure             ; fluid-let suppression kludge - fix later
+        exceptions              ; continuation-preview
+        tables
+        nodes		        ; schemify for ,expand command
+        reading-forms           ; $note-file-package
+	debug-data segments     ;  yucko
+	time                    ; real-time
+        primitives              ; memory-status
+        structure-refs)
+  (access primitives            ; want to both use and shadow collect
+          filenames             ;  and translate
+	  syntactic)		;  and expand
+  (files (env debug)))
+
+; Inspector
+
+(define-structures ((inspector (export inspect))
+		    (inspector-internal (export prepare-menu))
+		    (inspect-commands inspect-commands-interface))
+  (open scheme-level-2
+        command-processor       ; define-command, etc.
+	command-levels
+	define-record-types
+        fluids
+        debugging               ; command-loop-continuation
+        closures                ; closure-template
+        disclosers              ; template-debug-data, etc.
+        debug-data
+	evaluation		; eval
+	segments                ; get-debug-data
+        templates
+        continuations
+        names	                ; desyntaxify
+        records
+	records-internal
+        low-level               ; vector-unassigned?
+        locations
+        signals                 ; error
+        ;; tables  - not yet.
+        weak
+        util                    ; sublist
+        display-conditions)     ; limited-write
+  (files (env inspect)))
+
+(define-structure list-interfaces (export list-interface)
+  (open scheme-level-2 interfaces packages meta-types sort bindings)
+  (files (env list-interface)))
+
+
+; Package and interface mutation.
+
+(define-structure package-mutation package-mutation-interface
+  (open scheme-level-2
+        shadowing               ; shadow-location!
+        packages
+        interfaces
+	bindings
+        packages-internal
+        defpackage              ; set-verify-later!
+        locations
+        disclosers              ; location-info
+        handle
+        tables fluids weak signals)
+  (files (env pedit)))
+
+; The following hooks the compiler up with an exception handler for
+; unbound variables.
+
+(define-structure shadowing (export shadow-location!)
+  (open scheme-level-1
+        vm-exposure             ;primitive-catch
+        continuations templates locations code-vectors
+        exceptions signals
+        architecture)   ;(enum op global)
+  (files (env shadow)))     ;Exception handler to support package system
+
+
+; Disassembler
+
+(define-structures ((disassembler
+		       (export disassemble write-instruction))
+		    (disassemble-commands disassemble-commands-interface))
+  (open scheme-level-2
+        command-processor       ; define-command
+	disclosers              ; template-name
+        enumerated              ; enumerand->name
+        disclosers              ; location-name
+	evaluation		; eval
+        templates
+        continuations
+        locations
+        code-vectors
+        closures
+        architecture
+        signals)
+  (files (env disasm)))
+
+; Assembler.
+
+(define-structure assembling (export)	; No exports, this defines a compilator.
+  (open scheme-level-2
+	compiler		;define-compilator
+	segments
+	architecture
+	nodes			;node-form node-ref
+	bindings		;binding? binding-place
+        meta-types              ;value-type
+        templates               ; for Richard's version
+        signals                 ;error
+        enumerated              ;name->enumerand
+        code-vectors)
+  (files (env assem)))
+
+; Foo
+
+(define-structure assembler (export (lap :syntax))
+  (open scheme-level-2)
+  (for-syntax (open scheme-level-2 nodes meta-types assembling))
+  (begin
+    (define-syntax lap
+      (lambda (e r c)
+        (make-node (get-operator 'lap syntax-type) e)))))
+
+; Execution profiler.
+
+(define-structures ((profile (export run-with-profiling))
+		    (profile-commands profile-commands-interface))
+  (open scheme
+	command-processor
+        continuations
+        architecture
+        interrupts
+        tables
+        primitives     ; schedule-interrupt
+        wind
+        disclosers
+	time
+        sort
+        escapes)       ; primitive-cwcc
+  (files (env profile)))
+
+; Large integers and rational and complex numbers.
+
+(define-structure extended-numbers extended-numbers-interface
+  (open scheme-level-2
+        methods meta-methods
+        define-record-types
+        exceptions              ; make-opcode-generic!
+        primitives
+        architecture
+        signals
+	util
+        number-i/o)
+  (files (rts xnum)))
+
+(define-structure bignums bignums-interface
+  (open scheme-level-2
+        extended-numbers
+        methods signals)
+  (files (rts bignum))
+  (optimize auto-integrate))
+
+(define-structure innums (export )    ;inexact numbers
+  (open scheme-level-2
+        extended-numbers
+        methods signals
+        number-i/o)             ;string->integer
+  (files (rts innum)))
+
+(define-structure ratnums (export )    ;No exports
+  (open scheme-level-2
+        extended-numbers
+        methods signals
+        number-i/o)             ;string->integer
+  (files (rts ratnum)))
+
+(define-structure recnums (export )    ;No exports
+  (open scheme-level-2
+        extended-numbers
+        methods signals
+        number-i/o)             ;really-number->string
+  (files (rts recnum)))
+
+(define-structure floatnums
+		  (export floatnum? exp log sin cos tan asin acos atan sqrt)
+  (open scheme-level-2
+        extended-numbers
+        code-vectors
+        methods signals
+	enumerated
+	loopholes
+	more-types		;:double
+        primitives)             ;vm-extension double?
+  (files (rts floatnum))
+  (optimize auto-integrate))
+
+(define-structure time time-interface
+  (open scheme-level-1 primitives architecture enumerated)
+  (files (rts time)))
+
+(define-structure placeholders placeholder-interface
+  (open scheme-level-1 define-record-types
+	threads threads-internal
+	interrupts
+	signals)
+  (files (big placeholder))
+  (optimize auto-integrate))
+
+;----------------
+; Big Scheme
+
+(define-structure random (export make-random)
+  (open scheme-level-2 bitwise
+	signals)		;call-error
+  (files (big random)))
+
+(define-structure sort (export sort-list sort-list!)
+  (open scheme-level-2)
+  (files (big sort)))
+
+(define-structure pp (export p pretty-print define-indentation)
+  (open scheme-level-2
+        tables
+        methods)               ;disclose
+  (files (big pp)))
+
+
+; Bitwise logical operators on bignums.
+
+(define-structure bigbit (export )  ;No exports
+  (open scheme-level-2
+	bignums
+	methods
+        extended-numbers
+        ;; exceptions
+	;; architecture
+        bitwise
+	signals)
+  (files (big bigbit)))
+
+(define-structure formats (export format)
+  (open scheme-level-2 ascii signals
+	extended-ports)
+  (files (big format)))
+
+(define-structure extended-ports extended-ports-interface
+  (open scheme-level-2 records define-record-types ports i/o i/o-internal
+	code-vectors ascii
+	structure-refs
+	signals)
+  (access primitives)     ; copy-bytes!
+  (files (big more-port)))
+
+(define-structure destructuring (export (destructure :syntax))
+  (open scheme-level-2)
+  (files (big destructure)))
+
+(define-structure arrays arrays-interface
+  (open scheme-level-2 define-record-types signals)
+  (files (big array)))
+
+(define-structure receiving (export (receive :syntax))
+  (open scheme-level-2)
+  (files (big receive)))
+
+(define-structure defrecord defrecord-interface
+  (open scheme-level-1 records loopholes
+	primitives) ; unspecific
+  (files (big defrecord)))
+
+(define general-tables tables)    ; backward compatibility
+
+(define-structure big-util big-util-interface
+  (open scheme-level-2
+	formats
+	features		; immutable? make-immutable!
+        structure-refs)         ; structure-ref
+  (access signals               ; error
+          debugging		; breakpoint
+	  primitives)		; copy-bytes!
+  (files (big big-util)))
+
+(define-structure big-scheme big-scheme-interface
+  (open scheme-level-2
+	formats
+	sort
+        extended-ports
+	pp
+	enumerated
+        bitwise
+        ascii
+        bigbit
+	big-util
+        tables
+	;defrecord
+        destructuring
+        receiving))
+
+; Things needed for connecting with external code.
+
+(define-structure external-calls (export call-imported-binding
+					 lookup-imported-binding
+					 define-exported-binding
+					 shared-binding-ref
+					 ((import-definition
+					   import-lambda-definition)
+					  :syntax)
+					 add-finalizer!
+					 define-record-resumer
+					 call-external-value)
+  (open scheme-level-2 define-record-types
+	primitives
+        architecture
+	exceptions interrupts signals
+	placeholders
+	shared-bindings
+	byte-vectors
+	bitwise bigbit		;for {enter|extract}_integer() helpers
+	records)
+  (files (big import-def)
+	 (big callback)))
+
+(define-structure dynamic-externals dynamic-externals-interface
+  (open scheme-level-2 define-record-types tables
+        signals                 ;warn
+	primitives		;find-all-records
+	i/o			;current-error-port
+        code-vectors
+	external-calls)
+  (files (big external)))
+
+; Externals - this is obsolete; use external-calls and dynamic-externals
+; instead.
+
+(define-structure externals (compound-interface
+			       dynamic-externals-interface
+			       (export external-call
+				       null-terminate))
+  (open scheme-level-2 structure-refs
+	dynamic-externals)
+  (access external-calls)
+  (begin
+   ; We fake the old external-call primitive using the new one and a
+   ; a C helper procedure from c/unix/dynamo.c.
+
+    (define (external-call proc . args)
+      (let ((args (apply vector args)))
+	(old-external-call (external-value proc) args)))
+    
+    ((structure-ref external-calls import-lambda-definition)
+       old-external-call (proc args)
+       "s48_old_external_call")
+
+    ; All strings are now null terminated.
+    (define (null-terminate string) string)))
+
+; Rudimentary object dump and restore
+
+(define-structure dump/restore dump/restore-interface
+  (open scheme-level-1
+        number-i/o
+        tables
+        records
+        signals                 ;error
+        locations               ;make-undefined-location
+        closures
+        code-vectors            ;code vectors
+        fluids
+        ascii
+        bitwise
+        methods                 ;disclose
+        templates)              ;template-info
+  (files (big dump)))
+
+; Unix Sockets
+
+(define-structure sockets
+    (export open-socket
+	    close-socket
+	    socket-accept
+	    socket-port-number
+	    socket-client
+
+	    get-host-name
+
+	    ; From the old interface; I would like to get rid of these.
+	    socket-listen
+	    socket-listen-channels
+	    socket-client-channels
+	    )
+  (open scheme define-record-types
+	external-calls
+	low-channels	; channel? close-channel
+	signals		; error
+	interrupts	; enable-interrupts! disable-interrupts!
+	channel-i/o)	; wait-for-channel {in|out}put-channel->port
+  (files (big socket)))
+
+; Heap traverser
+
+(define-structure traverse
+                  (export traverse-depth-first traverse-breadth-first trail
+                          set-leaf-predicate! usual-leaf-predicate)
+  (open scheme-level-2
+        primitives              ; ?
+        queues tables
+        bitwise locations closures code-vectors
+        disclosers              ; foo
+        features                ; string-hash
+        low-level)              ; flush-the-symbol-table!, vector-unassigned?
+  (files (env traverse)))
+
+; Space analyzer
+
+(define-structure spatial (export space vector-space record-space)
+  (open scheme
+	architecture primitives assembler packages enumerated 
+	features sort locations display-conditions)
+  (files (env space)))
+
+; Structure & Interpretation compatibility
+
+(define-structure sicp sicp-interface
+  (open scheme-level-2 signals tables)
+  (files (misc sicp)))
+
+; red-black balanced binary search trees
+
+(define-structure search-trees search-trees-interface
+  (open scheme-level-2 define-record-types)
+  (optimize auto-integrate)
+  (files (big search-tree)))
+
+(define-structure finite-types (export ((define-finite-type
+					 define-enumerated-type) :syntax))
+  (open scheme-level-2 code-quote define-record-types
+	enumerated
+	features)		; make-immutable
+  (files (big finite-type)))
+
+; ... end of package definitions.
+
+; Temporary compatibility stuff
+(define-syntax define-signature
+  (syntax-rules () ((define-signature . ?rest) (define-interface . ?rest))))
+(define-syntax define-package
+  (syntax-rules () ((define-package . ?rest) (define-structures . ?rest))))
+(define table tables)
+(define record records)
+
+
+; Must list all the packages defined in this file that are to be
+; visible in the command processor's config package.
+
+(define-interface more-structures-interface
+  (export ((more-structures
+	    usual-features
+	    arrays
+	    assembler
+	    assembling
+	    general-tables
+	    bigbit
+	    bignums ratnums recnums floatnums
+	    build
+	    callback
+	    command-levels
+	    command-processor
+	    debugging
+	    define-record-types
+	    defrecord
+	    destructuring
+	    disassembler
+	    disclosers
+	    dump/restore
+	    dynamic-externals
+	    enum-case
+	    extended-numbers
+	    extended-ports
+	    externals
+	    external-calls
+	    finite-types
+	    formats
+	    innums
+	    inspector
+	    inspector-internal
+	    ;linked-queues
+	    list-interfaces
+	    ;more-threads
+	    package-commands-internal
+	    package-mutation
+	    placeholders
+	    pp
+	    ;profile
+	    queues
+	    time
+	    random
+	    receiving
+	    search-trees
+	    sicp
+	    sockets
+	    sort
+	    strong
+	    traverse
+	    spatial
+	    big-scheme
+	    big-util
+	    ;; From link-packages.scm:
+	    analysis
+	    debuginfo
+	    expander
+	    flatloading
+	    linker
+	    link-config
+	    reification			;?
+	    shadowing
+	    ;; Compatibility
+	    record table
+	    )
+	   :structure)
+	  ((define-signature define-package) :syntax)))
diff --git a/scheme/opt/analyze.scm b/scheme/opt/analyze.scm
new file mode 100644
index 0000000..dae8706
--- /dev/null
+++ b/scheme/opt/analyze.scm
@@ -0,0 +1,299 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Simple code analysis to determine whether it's a good idea to
+; in-line calls to a given procedure.
+
+; Hook into the byte code compiler.
+
+(set-optimizer! 'auto-integrate
+  (lambda (forms package)
+    (let ((out (current-noise-port)))
+      (newline out)
+      (display "Analyzing... " out) (force-output out)
+      (let* ((forms (find-usages (map force-node forms) package))
+	     (names (analyze-forms forms package)))
+	(cond ((not (null? names))
+	       (newline out)
+	       (display "Calls will be compiled in line: " out)
+	       (write (reverse names) out))
+	      (else
+	       (display "no in-line procedures" out)))
+	(newline out)
+	forms))))
+
+(define (analyze-forms scanned-nodes package)
+  (let ((inlines '()))
+    (for-each (lambda (node)
+		(let ((lhs (analyze-form node package)))
+		  (if lhs
+		      (set! inlines (cons lhs inlines)))))
+	      scanned-nodes)
+    inlines))
+
+(define (analyze-form node package)	;Return LHS iff calls will be inlined.
+  (if (define-node? node)
+      (let ((form (node-form node)))
+	(let ((lhs (node-form (cadr form)))
+	      (rhs (caddr form)))
+	  (let ((type (package-lookup-type package lhs)))
+	    (if (variable-type? type)
+		(require "not assigned" lhs #f)
+		(let ((method (inlinable-rhs? rhs type package lhs)))
+		  (if method
+		      (begin (package-add-static! package lhs method)
+			     (if (transform? method)
+				 lhs
+				 #f))
+		      #f))))))
+      #f))
+
+(define (inlinable-rhs? node type package lhs)
+  (cond ((lambda-node? node)
+	 (if (simple-lambda? node lhs package)
+	     (make-inline-transform node type package lhs)
+	     #f))
+	((name-node? node)
+	 (let ((name (node-form node)))
+	   (if (and (require "symbol rhs" (list lhs name)
+		      (symbol? name))
+		    (require "rhs bound" (list lhs name)
+		      (binding? (package-lookup-type package name)))
+		    (require "rhs unassigned" (list lhs name)
+		      (not (variable-type? (package-lookup-type package name))))
+		    (require "definitely procedure" (list lhs name)
+		      (procedure-type? (package-lookup-type package name))))
+	       (make-inline-transform node type package lhs)
+	       #f)))
+	((loophole-node? node)
+	 (inlinable-rhs? (caddr (node-form node)) type package lhs))
+;These should already be taken care of.
+;	((primitive-procedure-node? node)
+;	 (get-operator (cadr (node-form node))))
+	(else
+	 #f)))
+
+; We elect to integrate a procedure definition when
+;  1. The procedure in not n-ary,
+;  2. Every parameter is used exactly once and not assigned, and
+;  3. The analysis phase says that the body is acceptable (see below). 
+
+(define (simple-lambda? node id package)
+  (let* ((exp (node-form node))
+	 (formals (cadr exp))
+	 (body (caddr exp))
+	 (var-nodes (normalize-formals formals)))
+    (and (require "not n-ary" id
+	   (not (n-ary? formals)))
+	 (require "unique references" id
+	   (every (lambda (var-node)
+		    (let ((usage (node-ref var-node 'usage)))
+		      (and (= (usage-reference-count usage) 1)
+			   (= (usage-assignment-count usage) 0))))
+		  var-nodes))
+	 (require "good analysis" id
+	   (simple? (caddr exp) ret)))))
+
+(define operator/name (get-operator 'name 'leaf))
+
+; --------------------
+; SIMPLE? takes an alpha-converted expression and returns either
+;  - #f, meaning that the procedure in which the expression occurs
+;    has no chance of being fully inlinable, so we might as well give up,
+;  - #t, if there's no problem, or
+;  - 'empty, if there's no problem AND there are no lexical variable
+;    references at or below this node.
+; Foul situations are:
+;  - complex quotations (we don't want to make multiple copies of them)
+;  - a LAMBDA occurs (too much overhead, presumably)
+;  - a call that is not to a primitive and not a tail call
+
+
+; Main dispatch for analyzer
+; The name node analyzer needs the node; all others can get by with the
+; expression.
+
+(define (simple? node ret?)
+  ((operator-table-ref analyzers (node-operator-id node))
+     (if (name-node? node)
+	 node
+	 (node-form node))
+     ret?))
+
+(define (simple-list? exp-list)
+  (if (null? exp-list)
+      'empty
+      (let ((s1 (simple? (car exp-list) no-ret)))
+	(cond ((eq? s1 'empty)
+	       (simple-list? (cdr exp-list)))
+	      ((and s1
+		    (simple-list? (cdr exp-list)))
+	       #t)
+	      (else
+	       #f)))))
+
+; Particular operators
+
+(define analyzers
+  (make-operator-table (lambda (exp ret?)
+			 (simple-list? (cdr exp)))))
+
+(define (define-analyzer name proc)
+  (operator-define! analyzers name #f proc))
+
+(define-analyzer 'literal
+  (lambda (exp ret?)
+    (if (require "repeatable literal" #f
+	  (simple-literal? exp))
+	'empty
+	#f)))
+
+(define-analyzer 'unspecific
+  (lambda (exp ret?)
+    #t))
+
+; It's too awkward to try to inline references to unbound variables.
+; By special dispensation, this one analyzer receives the node instead of the
+; expression.  It needs the node to look up the binding record.
+
+(define-analyzer 'name
+  (lambda (node ret?)
+    ;; (if (node-ref node 'usage) #t 'empty)
+    ;;   ... (not (generated? exp)) ugh ...
+    (not (eq? (node-ref node 'binding)
+	      'unbound))))
+
+(define-analyzer 'quote
+  (lambda (exp ret?)
+    (if (require "repeatable quotation" #f
+	  (simple-literal? (cadr exp)))
+	'empty
+	#f)))
+
+(define-analyzer 'lambda
+  (lambda (exp ret?) #f))
+
+(define-analyzer 'letrec
+  (lambda (exp ret?) #f))
+
+(define-analyzer 'lap
+  (lambda (exp ret?) #f))
+
+; SET! loses because we might move a variable reference past a SET! on the
+; variable.  This can't happen if the SET! is the last thing done.
+; It's too awkward to try to inline references to unbound variables.
+
+(define-analyzer 'set!
+  (lambda (exp ret?)
+    (and ret?
+	 (not (eq? (node-ref (cadr exp) 'binding)
+		   'unbound))
+	 (simple? (caddr exp) no-ret))))
+
+(define-analyzer 'loophole
+  (lambda (exp ret?)
+    (simple? (caddr exp) ret?)))
+
+; Can't always fully in-line things like (lambda (a b c) (if a b c))
+
+(define-analyzer 'if
+  (lambda (exp ret?)
+    (and (eq? (simple? (caddr exp) ret?) 'empty)
+	 (eq? (simple? (cadddr exp) ret?) 'empty)
+	 (simple? (cadr exp) no-ret))))
+
+(define-analyzer 'begin
+  (lambda (exp ret?)
+    (let loop ((exps (cdr exp)))
+      (if (null? (cdr exps))
+	  (if (simple? (car exps) ret?) #t #f)
+	  (and (simple? (car exps) no-ret)
+	       (loop (cdr exps)))))))
+
+(define-analyzer 'call
+  (lambda (exp ret?)
+    (let ((static (static-value (car exp))))
+      (if (transform? static)
+	  (let* ((node (make-node (get-operator 'call) exp))
+		 (new-node (apply-inline-transform static
+						   (node-form node)
+						   (node-form (car exp)))))
+	    (if (eq? new-node node)
+		(really-simple-call? exp ret?)
+		(simple? new-node ret?)))
+	  (really-simple-call? exp ret?)))))
+
+; Return the static value of FORM, if any.
+
+(define (static-value form)
+  (if (and (node? form)
+	   (name-node? form))
+      (let ((probe (node-ref form 'binding)))
+	(if (binding? probe)
+	    (binding-static probe)
+	    #f))
+      #f))
+
+(define (really-simple-call? exp ret?)
+  (let ((proc (car exp)))
+    (and (require "non-local non-tail call" proc
+	   (or (and ret? (simple? proc no-ret))	;tail calls are ok
+	       (lexical-node? proc)))		;so are calls to arguments
+	 (simple-list? exp))))
+
+(define (lexical-node? node)
+  (not (node-ref node 'binding)))
+
+(define no-ret #f)
+
+(define ret #t)
+
+(define (simple-literal? x) ;Things that TRANSPORT won't copy.
+  (or (integer? x)
+      (boolean? x)
+      (null? x)
+      (char? x)
+      (symbol? x)))
+
+; --------------------
+; debugging hack
+
+(define (require reason id x)
+  (if (and *debug?* (not x))
+      (begin (write id)
+	     (display " lost because ")
+	     (display reason)
+	     (display " failed")
+	     (newline)))
+  x)
+
+(define *debug?* #f)
+
+; utility
+
+(define (package-lookup-type p name)
+  (let ((probe (package-lookup p name)))
+    (if (binding? probe)
+	(binding-type probe)
+	#f)))
+
+; --------------------
+
+(define lambda-node? (node-predicate 'lambda))
+(define name-node? (node-predicate 'name))
+(define loophole-node? (node-predicate 'loophole))
+(define define-node? (node-predicate 'define syntax-type))
+
+;----------------
+;(define (foo f p)
+;  (analyze-forms (alpha-forms (scan-file f p) p)))
+;
+;
+;(define (tst e p)
+;  (inlinable-rhs? (alpha e p) #f))
+;
+;(define b (make-compiler-base))
+;
+;(define p (make-simple-package (list b) eval #f))
+;
+;; (define b-stuff (alpha-structure b))
+;
diff --git a/scheme/opt/flatten.scm b/scheme/opt/flatten.scm
new file mode 100644
index 0000000..d373c8e
--- /dev/null
+++ b/scheme/opt/flatten.scm
@@ -0,0 +1,350 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Transmogrify code to produce flat lexical environments.
+;
+; This takes two passes.  The first finds the SET! variables so that cells can
+; be added for them.  The second pass adds a list of free variables to each
+; non-call-position LAMBDA node.  We don't need the free list for LET's.
+
+(set-optimizer! 'flat-environments
+  (lambda (forms package)
+    (map (lambda (form)
+	   (flatten-form (force form)))
+	 forms)))
+
+(define (flatten-form node)
+  (mark-set-variables! node)  ; we need to introduce cells for SET! variables
+  (if (define-node? node)
+      (let ((form (node-form node)))
+	(make-similar-node node
+			   `(define ,(cadr form)
+			      ,(call-with-values
+				(lambda ()
+				  (flatten-node (caddr form)))
+				(lambda (node ignore)
+				  node)))))
+      (call-with-values
+       (lambda ()
+	 (flatten-node node))
+       (lambda (node ignore)
+	 node))))
+
+; Main dispatch
+; This returns a new node and a list of free lexical variables.
+
+(define (flatten-node node)
+  ((operator-table-ref flatteners (node-operator-id node))
+     node))
+
+; Particular operators
+
+(define flatteners
+  (make-operator-table
+   (lambda (node)
+     (call-with-values
+      (lambda ()
+	(flatten-list (cdr (node-form node))))
+      (lambda (exps free)
+	(values (make-similar-node node
+				   (cons (car (node-form node))
+					 exps))
+		free))))))
+
+(define (define-flattener name proc)
+  (operator-define! flatteners name #f proc))
+
+(define (flatten-list nodes)
+  (let loop ((nodes nodes) (new '()) (free '()))
+    (if (null? nodes)
+	(values (reverse new) free)
+	(call-with-values
+	 (lambda ()
+	   (flatten-node (car nodes)))
+	 (lambda (node more-free)
+	   (loop (cdr nodes)
+		 (cons node new)
+		 (union more-free free)))))))
+
+(define (no-free-vars node)
+  (values node '()))
+
+(define-flattener 'literal             no-free-vars)
+(define-flattener 'quote               no-free-vars)
+(define-flattener 'primitive-procedure no-free-vars)
+(define-flattener 'lap                 no-free-vars)
+
+; LAMBDA's get changed to FLAT-LAMBDA's if the lexical environment is
+; non-empty.
+; (FLAT-LAMBDA -formals- -free-vars- -body-)
+
+(define-flattener 'lambda
+  (lambda (node)
+    (flatten-lambda node #t)))
+
+(define (flatten-lambda node closure?)
+  (let ((exp (node-form node)))
+    (call-with-values
+     (lambda ()
+       (convert-lambda-body node))
+     (lambda (body free)
+       (values (if closure?
+		   (make-node operator/flat-lambda
+			      (list 'flat-lambda
+				    (cadr exp)
+				    free
+				    body))
+		   (make-similar-node node
+				      (list (car exp)
+					    (cadr exp)
+					    body)))
+	       free)))))
+	  
+; Flatten the body and make cells for any SET! variables.
+
+(define (convert-lambda-body node)
+  (let* ((exp (node-form node))
+	 (var-nodes (normalize-formals (cadr exp))))
+    (call-with-values
+     (lambda ()
+       (flatten-node (caddr exp)))
+     (lambda (body free)
+       (values (add-cells body var-nodes)
+	       (set-difference free var-nodes))))))
+
+(define (add-cells exp vars)
+  (do ((vars vars (cdr vars))
+       (cells '() (if (assigned? (car vars))
+		      (cons (make-cell (car vars)) cells)
+		      cells)))
+      ((null? vars)
+       (if (null? cells)
+	   exp
+	   (make-node operator/begin
+		      `(begin
+			 ,@(reverse cells)
+			 ,exp))))))
+
+; Lexical nodes are free and may have cells.
+
+(define-flattener 'name
+  (lambda (node)
+    (if (node-ref node 'binding)
+	(values node '())
+	(values (if (assigned? node)
+		    (make-cell-ref node)
+		    node)
+		(list node)))))
+
+(define-flattener 'set!
+  (lambda (node)
+    (let* ((exp (node-form node))
+	   (var (cadr exp)))
+      (call-with-values
+       (lambda ()
+	 (flatten-node (caddr exp)))
+       (lambda (value free)
+	 (if (assigned? var)
+	     (values (make-cell-set! var value)
+		     (union (list var) free))
+	     (values (make-similar-node node
+					(list 'set! var value))
+		     free)))))))
+
+(define-flattener 'call
+  (lambda (node)
+    (let ((form (node-form node)))
+      (call-with-values
+       (lambda ()
+	 (flatten-list (cdr form)))
+       (lambda (args free)
+	 (call-with-values
+	  (lambda ()
+	    (if (lambda-node? (car form))
+		(flatten-lambda (car form) #f)
+		(flatten-node (car form))))
+	  (lambda (proc more-free)
+	    (values (make-similar-node node
+				       (cons proc args))
+		    (union free more-free)))))))))
+
+(define-flattener 'loophole
+  (lambda (node)
+    (let ((form (node-form node)))
+      (call-with-values
+       (lambda ()
+	 (flatten-node (caddr form)))
+       (lambda (new free)
+	 (values (make-similar-node node
+				    (list (car form)
+					  (cadr form)
+					  new))
+		 free))))))
+  
+; Use LET & SET! for LETREC.
+
+(define-flattener 'letrec
+  (lambda (node)
+    (let* ((form (node-form node))
+	   (vars (map car (cadr form)))
+	   (vals (map cadr (cadr form))))
+      (for-each (lambda (var)
+		  (node-set! var 'assigned #t))
+		vars)
+      (call-with-values
+       (lambda ()
+	 (flatten-list (cons (caddr form) vals)))
+       (lambda (nodes free)
+	 (values (make-node operator/call
+		    (cons (make-node operator/lambda
+			     `(lambda ,vars
+				,(make-node operator/begin
+				   `(begin ,@(map make-cell-set!
+						  vars
+						  (cdr nodes))
+					   ,(car nodes)))))
+			  (map (lambda (ignore)
+				 (make-unassigned-cell))
+			       vars)))
+		 (set-difference free vars)))))))
+
+(define-flattener 'lap
+  (lambda (node)
+    (caddr (node-form node))))
+
+;----------------
+; Is name-node NODE SET! anywhere?
+
+(define (assigned? node)
+  (node-ref node 'assigned))
+
+; Gather the info needed by ASSIGNED?.
+
+(define (mark-set-variables! node)
+  ((operator-table-ref mark-sets (node-operator-id node))
+   node))
+
+; Particular operators
+
+(define mark-sets
+  (make-operator-table
+   (lambda (node)
+     (for-each mark-set-variables! (cdr (node-form node))))))
+
+(define (define-set-marker name proc)
+  (operator-define! mark-sets name #f proc))
+
+(define (no-sets node) #f)
+
+(define-set-marker 'literal             no-sets)
+(define-set-marker 'quote               no-sets)
+(define-set-marker 'name                no-sets)
+(define-set-marker 'primitive-procedure no-sets)
+(define-set-marker 'lap                 no-sets)
+
+(define-set-marker 'lambda
+  (lambda (node)
+    (mark-set-variables! (caddr (node-form node)))))
+
+(define-set-marker 'set!
+  (lambda (node)
+    (let* ((exp (node-form node))
+	   (var (cadr exp)))
+      (if (not (node-ref var 'binding))
+	  (node-set! var 'assigned #t))
+      (mark-set-variables! (caddr exp)))))
+
+(define-set-marker 'loophole
+  (lambda (node)
+    (mark-set-variables! (caddr (node-form node)))))
+
+(define-set-marker 'call
+  (lambda (node)
+    (for-each mark-set-variables! (node-form node))))
+
+(define-set-marker 'letrec
+  (lambda (node)
+    (let ((form (node-form node)))
+      (for-each (lambda (spec)
+		  (mark-set-variables! (cadr spec)))
+		(cadr form))
+      (mark-set-variables! (caddr form)))))
+
+;----------------
+; Cell manipulation calls.
+
+(define (make-cell var)
+  (make-node operator/set!
+	     (list 'set!
+		   var
+		   (make-primop-call (make-cell-primop) var))))
+
+(define (make-unassigned-cell)
+  (make-primop-call (make-cell-primop)
+		    (make-node (get-operator 'unassigned)
+			       '(unassigned))))
+
+(define (make-cell-ref var)
+  (make-primop-call (cell-ref-primop) var))
+
+(define (make-cell-set! var value)
+  (make-primop-call (cell-set!-primop) var value))
+
+(define (make-primop-call primop . args)
+  (make-node operator/call
+	     (cons (make-node operator/literal
+			      primop)
+		   args)))
+
+;----------------
+; The operators and primops used here.
+
+(define operator/flat-lambda (get-operator 'flat-lambda))
+(define operator/lambda      (get-operator 'lambda))
+(define operator/begin       (get-operator 'begin))
+(define operator/literal     (get-operator 'literal))
+(define operator/call        (get-operator 'call))
+(define operator/unassigned  (get-operator 'unassigned))
+(define operator/set!        (get-operator 'set!))
+
+(define define-node? (node-predicate 'define))
+(define lambda-node? (node-predicate 'lambda))
+
+; We get loaded before these are defined, so we have to delay the lookups.
+
+(define-syntax define-primop
+  (syntax-rules ()
+    ((define-primop name id temp)
+     (begin
+       (define temp #f)
+       (define (name)
+	 (or temp
+	     (begin
+	       (set! temp (get-primop 'id))
+	       temp)))))))
+
+(define-primop make-cell-primop make-cell temp0)
+(define-primop cell-ref-primop  cell-ref  temp1)
+(define-primop cell-set!-primop cell-set! temp2)
+
+;----------------
+; Set operations on lists.
+
+(define (union vars1 vars2)
+  (if (null? vars2)
+      vars1
+      (let recur ((vars1 vars1))
+	(cond ((null? vars1)
+	       vars2)
+	      ((memq (car vars1) vars2)
+	       (recur (cdr vars1)))
+	      (else
+	       (cons (car vars1) (recur (cdr vars1))))))))
+
+(define (set-difference vars1 vars2)
+  (let recur ((vars1 vars1))
+    (cond ((null? vars1)
+	   '())
+	  ((memq (car vars1) vars2)
+	   (recur (cdr vars1)))
+	  (else
+	   (cons (car vars1) (recur (cdr vars1)))))))
diff --git a/scheme/opt/inline.scm b/scheme/opt/inline.scm
new file mode 100644
index 0000000..3d3edea
--- /dev/null
+++ b/scheme/opt/inline.scm
@@ -0,0 +1,216 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Once we know that we want something to be inlined, the following things
+; actually makes use of the fact.  For procedures for which all
+; arguments can be substituted unconditionally, we make a transform
+; (a macro, really) that performs the substitution.
+
+(define (make-inline-transform node type package name)
+  (let* ((free (find-node-usages node))
+	 (env (package->environment package))
+	 (qualified-free (map (lambda (name)
+				(name->qualified name env))
+			      free)))
+    (let ((form (clean-node node (map cons free qualified-free)))
+	  (aux-names (map (lambda (name)
+			    (do ((name name (qualified-parent-name name)))
+				((not (qualified? name))
+				 name)))
+			  qualified-free)))
+      (make-transform (inline-transform form aux-names)
+		      package		;env ?
+		      type
+		      `(inline-transform ',form ',aux-names)
+		      name))))
+
+; This routine is obligated to return an S-expression.
+; It's better not to rely on the constancy of node id's, so 
+; the output language is a sort of quasi-Scheme.  Any form that's a list
+; has an operator name in its car.
+;
+; ENV is an a-list mapping names to qualified (for package variables) or
+; non-clashing (for lexical variables) new names.
+;
+; What about SET! ?
+
+(define (clean-node node env)
+  (cond ((name-node? node)
+	 (clean-lookup env node))
+	((quote-node? node)
+	 `(quote ,(cadr (node-form node))))
+	((lambda-node? node)
+	 (clean-lambda node env))
+	((call-node? node)
+	 (cons 'call
+	       (map (lambda (node) (clean-node node env))
+		    (node-form node))))
+	((loophole-node? node)
+	 (let ((args (cdr (node-form node))))
+	   `(loophole ,(type->sexp (car args) #t)
+		      ,(clean-node (cadr args) env))))
+	;; LETREC had better not occur, since we ain't prepared for it
+	((pair? (node-form node))
+	 (cons (operator-name (node-operator node))
+	       (map (lambda (subnode)
+		      (clean-node subnode env))
+		    (cdr (node-form node)))))
+	(else (node-form node))))	;literal
+
+(define (clean-lambda node env)
+  (let* ((exp (node-form node))
+	 (formals (cadr exp))
+	 (env (fold (lambda (name-node env)
+		      `((,name-node . , (unused-name env (node-form name-node)))
+			. ,env))
+		    (normalize-formals formals)
+		    env)))
+    `(lambda ,(let recur ((foo formals))
+		(cond ((node? foo) (clean-lookup env foo))
+		      ((pair? foo)
+		       (cons (recur (car foo))
+			     (recur (cdr foo))))
+		      (else foo)))	; when does this happen?
+       ,(clean-node (caddr exp) env))))
+
+; Package names get looked up by name, lexical names get looked up by the
+; node itself.
+
+(define (clean-lookup env node)
+  (cdr (assq (if (binding? (node-ref node 'binding))
+		 (node-form node)
+		 node)
+	     env)))
+  
+; I'm aware that this is pedantic.
+
+(define (unused-name env name)
+  (let ((sym (if (generated? name)
+		 (generated-symbol name)
+		 name)))
+    (do ((i 0 (+ i 1))
+	 (name sym
+	       (string->symbol (string-append (symbol->string sym)
+					      (number->string i)))))
+	((every (lambda (pair)
+		  (not (eq? name (cdr pair))))
+		env)
+	 name))))
+
+;----------------
+; ST stands for substitution template (cf. MAKE-SUBSTITUTION-TEMPLATE)
+
+(define (inline-transform st aux-names)
+  (cons
+   (if (and (pair? st)
+	    (eq? (car st) 'lambda))
+       (let ((formals (cadr st))
+	     (body (caddr st)))
+	 (lambda (exp package rename)
+	   (let ((args (cdr exp)))
+	     (if (= (length formals) (length args))
+		 (reconstitute body
+			       package
+			       (make-substitution rename formals args))
+		 ;; No need to generate warning since the type checker will
+		 ;; produce one.  Besides, we don't want to produce a warning
+		 ;; for things like (> x y z).
+		 exp))))
+       (lambda (exp package rename)
+	 (cons (reconstitute st package rename)
+	       (cdr exp))))
+   aux-names))
+
+(define (make-substitution rename formals args)
+  (let ((subs (map cons formals args)))
+    (lambda (name)
+      (let ((probe (assq name subs)))
+	(cond (probe
+	       (cdr probe))
+	      ((generated? name)
+	       (signal 'note
+		       "this shouldn't happen - make-substitution"
+		       name)
+	       name)			;TEMPORARY KLUDGE.
+	      (else
+	       (rename name)))))))
+
+; Turn an s-expression back into a node.
+; ST is an S-expression as returned by MAKE-SUBSTITUTION-TEMPLATE.
+
+(define (reconstitute st package rename)
+  (let label ((st st))
+    (cond ((symbol? st)
+	   (let ((foo (rename st)))
+	     (if (name? foo)
+		 (reconstitute-name foo package)
+		 foo)))
+	  ((qualified? st)
+	   (reconstitute-name (qualified->name st rename) package))
+	  ((pair? st)
+	   (case (car st)
+	     ((quote)
+	      (make-node (get-operator 'quote) st))
+	     ((call)
+	      (make-node (get-operator 'call)
+			 (map label (cdr st))))
+	     ((loophole)
+	      (make-node (get-operator 'loophole)
+			 (list 'loophole
+			       (sexp->type (cadr st) #t)
+			       (label (caddr st)))))
+	     ((lambda)
+	      (error "lambda substitution NYI" st))
+	     (else
+	      (let ((keyword (car st)))
+		(make-node (get-operator keyword)
+			   (cons keyword
+				 (map label (cdr st))))))))
+	  (else
+	   (make-node operator/literal st)))))
+
+(define (reconstitute-name name package)
+  (let ((binding (package-lookup package name))
+	(node (make-node operator/name name)))
+    (if (binding? binding)
+	(node-set! node 'binding binding))
+    node))
+
+(define operator/name (get-operator 'name))
+(define operator/literal (get-operator 'literal))
+
+; --------------------
+; Convert a qualified name #(>> parent-name symbol) to an alias.
+
+(define (qualified->name qualified rename)
+  (let recur ((name qualified))
+    (if (qualified? name)
+	(let ((parent (recur (qualified-parent-name name))))
+	  (generate-name (qualified-symbol name)
+			 (get-qualified-env (generated-env parent)
+					    (generated-symbol parent))
+			 parent))
+	(rename name))))
+
+(define (get-qualified-env env parent)
+  (let ((binding (generic-lookup env parent)))
+    (if (binding? binding)
+	(let ((static (binding-static binding)))
+	  (cond ((transform? static)
+		 (transform-env static))
+		((structure? static)
+		 static)
+		(else
+		 (error "invalid qualified reference"
+			env parent static))))
+	(error "invalid qualified reference"
+	       env parent binding))))
+
+;----------------
+
+(define quote-node? (node-predicate 'quote))
+(define call-node? (node-predicate 'call))
+(define lambda-node? (node-predicate 'lambda))
+(define name-node? (node-predicate 'name))
+(define loophole-node? (node-predicate 'loophole))
+
+
diff --git a/scheme/opt/sort.scm b/scheme/opt/sort.scm
new file mode 100644
index 0000000..58a4489
--- /dev/null
+++ b/scheme/opt/sort.scm
@@ -0,0 +1,117 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Topological sort on forms.
+
+; Puts top-level forms in the following order:
+;
+; (DEFINE X <literal>)
+; (DEFINE Z (LAMBDA ...))
+; ...everything else...
+;
+; Every (DEFINE W ...) for which W is never SET! is followed by all forms
+; (DEFINE V W).
+;
+; The procedure definitions are topologically sorted; whenever possible no
+; use of a variable occurs before its definition.
+;
+; COMPLETE? is true if STUFF contains the entire body of a module.
+;
+; This uses the FREE-VARIABLES field set by analyze.scm.
+
+(define (sort-forms nodes complete?)
+  (let ((table (make-name-table))
+	(procs '())
+	(literals '())
+	(aliases '())
+	(rest '()))
+    (for-each (lambda (node)
+		(let ((form (make-form node)))
+		  (if (define-node? node)
+		      (let ((name (node-form (cadr (node-form node))))
+			    (value (caddr (node-form node))))
+			(table-set! table name form)
+			(cond ((lambda-node? value)
+			       (set! procs (cons form procs)))
+			      ((name-node? value)
+			       (set! aliases (cons form aliases))
+			       (set! rest (cons form rest)))
+			      ((or (quote-node? value)
+				   (literal-node? value))
+			       (set! literals (cons form literals)))
+			      (else
+			       (set! rest (cons form rest)))))
+		      (set! rest (cons form rest)))))
+	      (reverse nodes))
+    (for-each (lambda (form)
+		(maybe-make-aliased form table))
+	      aliases)
+    (insert-aliases
+     (append literals
+	     (topologically-sort procs table)
+	     (filter form-unaliased? rest)))))
+
+(define (stuff-count s)
+  (apply + (map (lambda (s) (length (cdr s))) s)))
+
+; For (DEFINE A B) add the form to the list of B's aliases if B is defined
+; in the current package and never SET!.
+
+(define (maybe-make-aliased form table)
+  (let* ((value (caddr (node-form (form-node form))))
+	 (maker (table-ref table (node-form value))))
+    (if (and (node-ref value 'binding)
+	     maker
+	     (= 0 (usage-assignment-count
+		    (node-ref (cadr (node-form (form-node maker))) 'usage))))
+	(begin
+	  (set-form-aliases! maker (cons form (form-aliases maker)))
+	  (set-form-unaliased?! form #f)))))
+
+(define (topologically-sort forms table)
+  (apply append
+	 (strongly-connected-components
+	   forms
+	   (lambda (form)
+	     (filter (lambda (f)
+		       (and f
+			    (lambda-node? (caddr (node-form (form-node f))))))
+		     (map (lambda (name)
+			    (table-ref table (node-form name)))
+			  (form-free form))))
+	   form-temp
+	   set-form-temp!)))
+
+(define-record-type form :form
+  (really-make-form node free aliases unaliased?)
+  form?
+  (node form-node)
+  (aliases form-aliases set-form-aliases!)
+  (unaliased? form-unaliased? set-form-unaliased?!)
+  (free form-free set-form-free!)
+  (temp form-temp set-form-temp!))
+
+(define-record-discloser :form
+  (lambda (form)
+    (list 'form
+	  (let ((node (form-node form)))
+	    (if (define-node? node)
+		(node-form (cadr (node-form node)))
+		node)))))
+
+(define (make-form node)
+  (really-make-form node
+		    (map usage-name-node
+			 (node-ref node 'free-variables))
+		    '()		; aliases
+		    #t))	; unaliased?
+
+; (DEFINE A ...) is followed by all forms (DEFINE X A).
+
+(define (insert-aliases forms)
+  (let loop ((forms forms) (done '()))
+    (if (null? forms)
+	(reverse done)
+	(let ((form (car forms)))
+	  (loop (append (form-aliases form) (cdr forms))
+		(cons (form-node form) done))))))
diff --git a/scheme/opt/tst.scm b/scheme/opt/tst.scm
new file mode 100644
index 0000000..50a878f
--- /dev/null
+++ b/scheme/opt/tst.scm
@@ -0,0 +1,26 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+
+(define-structure primitives (make-compiler-base))
+
+; "Level 1"
+
+(define-structures ((scheme-level-1 scheme-level-1-interface)
+		    (scheme-level-1-internal scheme-level-1-internal-interface)
+		    (bitwise bitwise-interface)
+		    (util util-interface)
+		    (signals signals-interface)
+		    (features features-interface)
+		    (ascii ascii-interface)
+		    (structure-refs (export structure-ref)))
+  (open primitives)
+  (usual-transforms)
+  (optimize auto-integrate)
+  (files (rts base)
+	 (rts util)
+	 (rts signal)
+	 (rts number)
+	 (rts lize)	  ; Rationalize
+	 ))
+
diff --git a/scheme/opt/usage.scm b/scheme/opt/usage.scm
new file mode 100644
index 0000000..cd151f2
--- /dev/null
+++ b/scheme/opt/usage.scm
@@ -0,0 +1,230 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Getting usage counts and doing a topological sort (so that definitions
+; will be seen before uses, where possible).
+;
+; We change the types of all unassigned top-level variables from
+; (VARIABLE <type>) to <type>.
+;
+; Steps:
+;  1. Make usage records for the variables bound by this package.
+;  2. Analyze each form to update the usage records and to find the referenced
+;     variables defined in this package.
+;  3. Update the types of the variables based on their usages.
+;  4. Do a topological sort of the forms using the referenced-variable sets
+;     from step 2.
+
+(define (find-usages forms package)
+  (let ((usages (make-name-table)))
+    (for-each (lambda (form)
+		(if (define-node? form)
+		    (let* ((lhs (cadr (node-form form)))
+			   (usage (make-package-usage lhs)))
+		      (table-set! usages (node-form lhs) usage)
+		      (node-set! lhs 'usage usage))))
+	      forms)
+    (for-each (lambda (form)
+		(node-set! form
+			   'free-variables
+			   (analyze form
+				    '()
+				    (lambda (node)
+				      (table-ref usages (node-form node))))))
+	      forms)
+    (for-each (lambda (form)
+		(if (define-node? form)
+		    (maybe-update-known-type form package)))
+	      forms)
+    (sort-forms forms #t)))
+
+(define (maybe-update-known-type node package)
+  (let* ((lhs (cadr (node-form node)))
+	 (usage (node-ref lhs 'usage)))
+    (if (= 0 (usage-assignment-count usage))
+	(let ((new-type (reconstruct-type (caddr (node-form node))
+					  (package->environment package))))
+	  (if (subtype? new-type any-values-type)
+	      (package-refine-type! package
+				    (node-form lhs)
+				    (if (subtype? new-type value-type)
+					new-type
+					value-type))
+	      (warn "ill-typed right-hand side"
+		    (schemify node)
+		    (type->sexp new-type #t)))))))
+
+;----------------
+; Another entry point.
+; Here we want to return all package variables found, not just the ones from
+; this package.  We also don't update the actual usage records for package
+; variables, as they refer to the entire package, not just one form.
+
+(define (find-node-usages node)
+  (let* ((usages (make-name-table))
+	 (referenced (analyze node
+			      '()
+			      (lambda (node)
+				(let ((usage (node-ref node 'usage)))
+				  (if (and usage
+					   (not (package-usage? usage)))
+				      #f
+				      (let ((name (node-form node)))
+					(or (table-ref usages name)
+					    (let ((usage (make-package-usage node)))
+					      (table-set! usages name usage)
+					      usage)))))))))
+    (map (lambda (usage)
+	   (node-form (usage-name-node usage)))
+	 referenced)))
+    
+;----------------
+; The usual node walk.  FREE is a list of usage records for package variables
+; that have been seen so far.  USAGES is a function that maps names to usages.
+
+(define (analyze node free usages)
+  ((operator-table-ref usage-analyzers (node-operator-id node))
+     node
+     free
+     usages))
+
+(define (analyze-nodes nodes free usages)
+  (reduce (lambda (node free)
+	    (analyze node free usages))
+	  free
+	  nodes))
+
+(define usage-analyzers
+  (make-operator-table (lambda (node free usages)
+			 (analyze-nodes (node-form node) free usages))))
+
+(define (define-usage-analyzer name type proc)
+  (operator-define! usage-analyzers name type proc))
+
+(define (nothing node free usages) free)
+
+(define-usage-analyzer 'literal    #f nothing)
+(define-usage-analyzer 'unspecific #f nothing)
+(define-usage-analyzer 'unassigned #f nothing)
+(define-usage-analyzer 'quote               syntax-type nothing)
+(define-usage-analyzer 'primitive-procedure syntax-type nothing)
+
+(define-usage-analyzer 'name #f
+  (lambda (node free usages)
+    (note-reference! node usages)
+    (add-if-free node free usages)))
+
+; If NODE has a usage record, then add it to FREE if it (the usage record) isn't
+; already there.
+
+(define (add-if-free node free usages)
+  (let ((usage (usages node)))
+    (if (and usage
+	     (not (memq usage free)))
+	(cons usage free)
+	free)))
+
+(define-usage-analyzer 'call #f
+  (lambda (node free usages)
+    (let* ((exp (node-form node))
+	   (proc (car exp)))
+      (if (name-node? proc)
+	  (note-operator! proc usages))
+      (analyze-nodes exp free usages))))
+
+(define-usage-analyzer 'lambda syntax-type
+  (lambda (node free usages)
+    (let* ((exp (node-form node))
+	   (formals (cadr exp)))
+      (for-each (lambda (node)
+		  (node-set! node 'usage (make-usage)))
+		(normalize-formals formals))
+      (analyze (caddr exp) free usages))))
+
+(define-usage-analyzer 'letrec syntax-type
+  (lambda (node free usages)
+    (let* ((exp (node-form node))
+	   (specs (cadr exp))
+	   (body (caddr exp)))
+      (for-each (lambda (spec)
+		  (node-set! (car spec) 'usage (make-usage)))
+		specs)
+      (analyze body
+	       (analyze-nodes (map cadr specs)
+			      free
+			      usages)
+	       usages))))
+
+(define-usage-analyzer 'begin syntax-type
+  (lambda (node free usages)
+    (analyze-nodes (cdr (node-form node)) free usages)))
+
+(define-usage-analyzer 'set! syntax-type
+  (lambda (node free usages)
+    (let ((exp (node-form node)))
+      (let ((lhs (cadr exp))
+	    (rhs (caddr exp)))
+	(note-assignment! lhs usages)
+	(analyze rhs (add-if-free lhs free usages) usages)))))
+
+(define-usage-analyzer 'define syntax-type
+  (lambda (node free usages)
+    (analyze (caddr (node-form node))
+	     free
+	     usages)))
+
+(define-usage-analyzer 'if syntax-type
+  (lambda (node free usages)
+    (analyze-nodes (cdr (node-form node)) free usages)))
+
+(define-usage-analyzer 'lap syntax-type
+  (lambda (node free usages)
+    (analyze-nodes (caddr (node-form node))
+		   free
+		   usages)))
+
+(define-usage-analyzer 'loophole syntax-type
+  (lambda (node free usages)
+    (analyze (caddr (node-form node))
+	     free
+	     usages)))
+
+;--------------------
+; Usage records record the number of times that a variable is referenced, set!,
+; and called.
+
+(define-record-type usage :usage
+  (really-make-usage name-node reference operator assignment)
+  usage?
+  (name-node usage-name-node)  ; only for package variables
+  (reference usage-reference-count set-reference!)
+  (operator usage-operator-count set-operator!)
+  (assignment usage-assignment-count set-assignment!))
+
+(define (make-usage)
+  (really-make-usage #f 0 0 0))
+
+(define (make-package-usage name-node)
+  (really-make-usage name-node 0 0 0))
+
+(define (package-usage? usage)
+  (usage-name-node usage))
+
+(define (usage-incrementator ref set)
+  (lambda (node usages)
+    (let ((v (or (node-ref node 'usage)
+		 (usages node))))
+      (if v
+	  (set v (+ (ref v) 1))))))
+
+(define note-reference! (usage-incrementator usage-reference-count set-reference!))
+(define note-operator! (usage-incrementator usage-operator-count set-operator!))
+(define note-assignment! (usage-incrementator usage-assignment-count set-assignment!))
+
+;----------------
+
+(define lambda-node? (node-predicate 'lambda))
+(define quote-node? (node-predicate 'quote))
+(define literal-node? (node-predicate 'literal))
+(define call-node? (node-predicate 'call))
+(define name-node? (node-predicate 'name 'leaf))
+(define define-node? (node-predicate 'define syntax-type))
diff --git a/scheme/packages.scm b/scheme/packages.scm
new file mode 100644
index 0000000..ec20f77
--- /dev/null
+++ b/scheme/packages.scm
@@ -0,0 +1,383 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Meta-modules: the big picture.
+
+; Various implementations of Primitive Scheme.
+
+(define-structure low-structures low-structures-interface
+  (open meta-module-system the-interfaces)
+  (files low-packages))
+
+(define-structure debug-low-structures low-structures-interface
+  (open meta-module-system the-interfaces
+	;; built-in-structures
+	)
+  (files (alt low-packages)))
+
+
+; Usual Scheme 48 run-time system.
+
+(define (make-run-time low-structures)
+  (structures (run-time-structures-interface
+	       run-time-internals-structures-interface
+	       features-structures-interface)
+    (open meta-module-system the-interfaces
+	  low-structures)
+    (files rts-packages)))
+
+
+; Alternatives to the usual Scheme 48 run-time system.
+
+(define-structure alt-features-structures features-structures-interface
+  (open meta-module-system the-interfaces)
+  (files (alt features-packages)))
+
+(define-structure cheat-features-structures features-structures-interface
+  (open meta-module-system the-interfaces)
+  (begin (define-structures ((ascii ascii-interface)
+			     (bitwise bitwise-interface)
+			     (code-vectors code-vectors-interface)
+			     (features features-interface)
+			     (records records-interface)
+			     (signals signals-interface))
+	   ;; Assumes use of FLATLOAD.  The implementations of these
+	   ;; structures will become available via some miracle, e.g.
+	   ;; a command ",open signals ... code-vectors" or an
+	   ;; explicit LOAD of something.  Cf. the rule for
+	   ;; link/linker.image in the Makefile.
+	   )))
+
+(define-module (make-alt-run-time features-structures)
+  (structures (low-structures-interface
+	       run-time-structures-interface)
+    (open meta-module-system the-interfaces
+	  features-structures)
+    (files alt-packages
+	   (alt low-packages))))
+
+
+; Byte-code compiler and related things.
+
+(define-module (make-compiler-structures run-time-structures
+					 features-structures)
+
+  (define-structure compiler-structures compiler-structures-interface
+    (open meta-module-system the-interfaces
+	  run-time-structures
+	  features-structures)
+    (files comp-packages))
+
+  compiler-structures)
+
+
+; The initial system (initial.image).  Cf. the rule for initial.image
+; in the Makefile.
+
+(define (make-initial-structures low-structures
+				 run-time-structures
+				 run-time-internals-structures
+				 features-structures
+				 compiler-structures)
+  (structure initial-structures-interface
+    (open meta-module-system the-interfaces
+	  low-structures		;Cf. desirable-structures
+	  run-time-structures
+	  features-structures
+	  run-time-internals-structures
+	  compiler-structures)
+    (files initial-packages)))
+
+
+; Small systems.
+
+(define-structure (make-debug-structures low-structures
+					 run-time-structures
+					 run-time-internals-structures
+					 features-structures
+					 initial-structures)
+  (structure debug-structures-interface
+    (open meta-module-system the-interfaces
+	  low-structures
+	  run-time-structures
+	  run-time-internals-structures
+	  features-structures
+	  initial-structures)
+    (files debug-packages)))
+
+
+; Static linker.
+
+(define-module (make-linker-structures features-structures
+				       run-time-structures
+				       compiler-structures)
+
+  (define-structure linker-structures linker-structures-interface
+    (open meta-module-system the-interfaces
+	  features-structures
+	  run-time-structures
+	  compiler-structures)
+    (files link-packages))
+
+  linker-structures)
+
+
+
+; The following definition of THE-INTERFACES assumes that we're
+; "flatloading."  If we were really using the module system, then its
+; interface would have to include all of the interfaces defined in
+; interfaces.scm, and it would need a (files interfaces) clause.
+
+(define-structure the-interfaces the-interfaces-interface
+  (open )
+  ;; (files interfaces)
+  )
+(define-interface the-interfaces-interface
+  (export scheme-level-0-interface
+	  primitives-interface
+	  ;; ... etc. etc. ad nauseum
+	  for-reification-interface))
+
+; This definition of META-MODULE-SYSTEM assumes that we're flatloading.
+; If we weren't, it would have to be
+;   (def meta-module-system module-system)
+; instead.
+
+(define-structure meta-module-system (export ) (open ))  ;Kludge
+
+
+
+; --------------------
+; Particular assemblies:
+
+; The usual run-time system (for initial.image, etc.).
+
+(def run-time-structures run-time-internals-structures features-structures
+  (make-run-time low-structures))
+
+
+; The byte-code compiler as constituted for initial.image and friends.
+
+(def compiler-structures
+  (make-compiler-structures run-time-structures
+			    features-structures))
+
+
+; The initial system made in the usual way.
+
+(def initial-structures
+  (make-initial-structures low-structures
+			   run-time-structures
+			   run-time-internals-structures
+			   features-structures
+			   compiler-structures))
+
+
+; Debug systems.
+
+(def debug-structures
+  (make-debug-structures low-structures
+			 run-time-structures
+			 run-time-internals-structures
+			 features-structures
+			 initial-structures))
+
+
+; The usual development environment (scheme48.image).
+
+(define-structure usual-structures (export (usual-features :structure))
+  (open meta-module-system
+	run-time-structures
+	compiler-structures
+	initial-structures
+	(make-linker-structures features-structures
+				run-time-structures
+				compiler-structures))
+  (files ;; more-interfaces, when not flatloading
+	 more-packages))
+
+
+; The linker running in a random Scheme system (Lucid, Scheme->C, or
+; old version of Scheme 48).  If running in Scheme 48, this becomes
+; link/linker.image.
+
+(def alt-low-structures alt-run-time-structures
+  (make-alt-run-time cheat-features-structures))
+
+(def linker-structures
+  (make-linker-structures cheat-features-structures
+			  alt-run-time-structures
+			  (make-compiler-structures cheat-features-structures
+						    alt-run-time-structures)))
+
+
+
+; --------------------
+; Meta-interfaces.
+; These are ignored by FLATLOAD, but DESIRABLE-STRUCTURES (in
+; initial.scm) extracts the list of structures to be reified from
+; them.
+
+(define-interface features-structures-interface
+  (export ((ascii
+	    bitwise
+	    code-vectors
+	    features
+	    records
+	    signals)
+	   :structure)))
+
+; Of the features-structures, only records isn't also
+; a low-structure.
+
+(define-interface low-structures-interface
+  (export ((ascii
+	    bitwise
+	    byte-vectors
+	    code-vectors
+	    features
+	    ;; records  - lose
+	    signals
+	    channels
+	    closures
+	    code-quote
+	    escapes
+	    locations
+	    loopholes
+	    low-channels
+	    low-level
+	    ports
+	    primitives
+	    scheme-level-0
+	    shared-bindings
+	    silly
+	    source-file-names
+	    structure-refs
+	    debug-messages
+	    vm-exposure
+	    write-images)
+	   :structure)))
+
+(define-interface run-time-structures-interface
+  (export ((architecture
+	    channel-i/o
+	    define-record-types
+	    enum-case
+	    enumerated
+	    fluids
+	    ;linked-queues
+	    locks
+	    queues
+	    scheduler
+	    scheme-level-1
+	    scheme-level-2
+	    templates
+	    threads
+	    threads-internal
+	    util
+	    weak)
+	   :structure)))
+
+(define-interface run-time-internals-structures-interface
+  (export ((conditions
+	    continuations
+	    display-conditions
+	    ;; escapes
+	    exceptions
+	    fluids-internal
+	    handle
+	    i/o
+	    i/o-internal
+	    methods
+	    meta-methods
+	    interrupts
+	    low-level
+	    more-types
+	    number-i/o
+	    ;; primitives
+	    reading
+	    records-internal
+	    root-scheduler
+	    session-data
+	    usual-resumer
+	    ;; silly
+	    ;; structure-refs
+	    ;; vm-exposure
+	    wind
+	    writing)
+	   :structure)))
+  
+(define-interface compiler-structures-interface
+  (export ((analysis
+	    bindings
+	    compiler
+	    compiler-envs
+	    compile-packages
+	    debug-data
+	    defpackage
+	    filenames
+	    flat-environments
+	    inline
+	    meta-types
+	    interfaces
+	    module-system
+	    names
+	    nodes
+	    optimizer
+	    packages
+	    packages-internal
+	    primops
+	    reading-forms
+	    reconstruction
+	    segments
+	    scan-package
+	    syntactic
+	    strong
+	    tables
+	    transforms
+	    types
+	    undefined
+	    usual-macros)
+	   :structure)))
+
+(define-interface initial-structures-interface
+  (export ((environments
+	    evaluation
+	    ensures-loaded
+	    ;; for-reification is in there, but shouldn't get reified.
+	    )
+	   :structure)
+	  ((make-scheme
+	    make-mini-command
+	    make-initial-system)
+	   :procedure)))
+
+
+; Initial + usual (scheme48.image).
+
+(define-interface linker-structures-interface
+  (export ((analysis
+	    debuginfo
+	    expander
+	    flatloading
+	    linker
+	    link-config
+	    loadc
+	    reification
+	    usages)
+	   :structure)))
+
+(define debug-structures-interface
+  (export ((mini-eval
+	    mini-environments
+	    mini-scheme
+	    little-system
+	    mini-for-reification
+	    mini-packages
+	    mini-system
+	    run
+	    medium-scheme
+	    medium-system)
+	   :structure)
+	  mini-eval
+	  mini-environments))
diff --git a/scheme/prescheme/interface.scm b/scheme/prescheme/interface.scm
new file mode 100644
index 0000000..9fdd278
--- /dev/null
+++ b/scheme/prescheme/interface.scm
@@ -0,0 +1,88 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+(define-interface prescheme-interface
+  (export ((if begin lambda letrec quote set!
+	       define define-syntax let-syntax
+	       and cond case do let let* or
+	       quasiquote
+	       ;syntax-rules
+	       ) :syntax)  ; no delay
+	  ;; letrec-syntax  -- not yet implemented
+	  
+	  (goto :syntax)
+	  (external :syntax)
+
+	  ((define-enumeration define-external-enumeration enum) :syntax)
+	  ((name->enumerand enumerand->name) :syntax)  ; loadtime only
+
+	  not
+
+	  eq?
+	  + - * = <  ; /
+	  <= > >=
+	  abs
+	  expt
+	  quotient remainder
+	  ; floor numerator denominator
+	  ; real-part imag-part
+	  ; exp log sin cos tan asin acos atan sqrt
+	  ; angle magnitude make-polar make-rectangular
+	  min max
+	  char=? char<?
+
+	  ;; Data manipulation
+	  make-vector vector-length
+	  vector-ref vector-set!
+
+	  make-string string-length
+	  string-ref string-set!
+
+	  deallocate
+	  null-pointer?
+
+	  values call-with-values
+
+	  current-input-port current-output-port current-error-port
+	  open-input-file open-output-file
+	  close-output-port close-input-port
+
+	  read-char peek-char read-integer
+	  write-char newline write-string write-integer
+	  force-output
+
+	  (errors :syntax)
+	  error-string
+
+	  ascii->char char->ascii
+	  
+	  shift-left arithmetic-shift-right logical-shift-right
+	  bitwise-and bitwise-ior bitwise-xor bitwise-not
+	  unspecific
+	  error
+	  ))
+
+; memory (malloc and free)
+
+(define-interface ps-memory-interface
+  (export allocate-memory
+	  deallocate-memory
+
+	  unsigned-byte-ref unsigned-byte-set!
+	  word-ref word-set!
+
+	  address?
+	  null-address null-address?
+
+	  address+ address- address-difference
+	  address= address< address<= address> address>=
+	  address->integer integer->address
+
+	  copy-memory! memory-equal?
+
+	  char-pointer->string char-pointer->nul-terminated-string
+
+	  read-block write-block))
+
+(define-interface ps-receive-interface
+  (export receive))
+
diff --git a/scheme/prescheme/load.scm b/scheme/prescheme/load.scm
new file mode 100644
index 0000000..789d99c
--- /dev/null
+++ b/scheme/prescheme/load.scm
@@ -0,0 +1,8 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; To load Pre-Scheme, do
+;   ,exec ,load <this file>
+
+(config)
+(load "interface.scm")
+(load "package-defs.scm")
diff --git a/scheme/prescheme/memory.scm b/scheme/prescheme/memory.scm
new file mode 100644
index 0000000..7c2b69b
--- /dev/null
+++ b/scheme/prescheme/memory.scm
@@ -0,0 +1,255 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; An implementation of Pre-Scheme's memory interface that can detect some
+; stray reads and writes.  It has numerous limitiations:
+;    Allocations are always on page boundaries.
+;    No more than 16 megabytes can be allocated at once.
+;    More than 32 or 64 or so allocations result in addresses being
+;       bignums (dealloctions have no effect on this).
+;
+; Memory is represented as a vector of byte-vectors, with each byte-vector
+; representing a 16-megabyte page.  Allocations are always made on page
+; boundaries, so the byte-vectors only need be as large as the allocated
+; areas.  Pages are never re-used.
+;
+; (Scheme 48 still calls byte-vectors code-vectors.)
+
+
+; Addresses are distinct from integers.
+
+(define-record-type address :address
+  (make-address index)
+  address?
+  (index address-index))
+  
+(define-record-discloser :address
+  (lambda (addr) (list 'address (address-index addr))))
+
+; We add 100000000 to addresses to make them
+
+(define address-offset 100000000)
+
+(define (address->integer addr)
+  (+ (address-index addr) address-offset))
+
+(define (integer->address int)
+  (make-address (- int address-offset)))
+
+(define (address+ address integer)
+  (make-address (+ (address-index address) integer)))
+
+(define (address- address integer)
+  (make-address (- (address-index address) integer)))
+
+(define (address-binop op)
+  (lambda (address1 address2)
+    (op (address-index address1) (address-index address2))))
+
+(define address-difference (address-binop -))
+(define address= (address-binop =))
+(define address< (address-binop <))
+(define address<= (address-binop <=))
+(define address> (address-binop >))
+(define address>= (address-binop >=))
+
+(define null-address (make-address -1))
+
+(define (null-address? address)
+  (address= address null-address))
+
+; Memory
+
+(define *memory* (make-vector 16 #f))    ; vector of pages
+(define log-max-size 24)                 ; log of page size
+(define address-shift (- log-max-size))  ; turns addresses into page indices
+
+(define max-size (arithmetic-shift 1 log-max-size))  ; page size
+
+(define address-mask                     ; mask to get address within page
+  (- (arithmetic-shift 1 log-max-size) 1))
+
+(define *next-index* 0)                  ; next available page
+
+(define (reinitialize-memory)
+  (set! *memory* (make-vector 16 #f))
+  (set! *next-index* 0))
+
+; Extend the page vector if necessary, and then make a page of the
+; appropriate size.
+
+(define (allocate-memory size)
+  (cond ((> size max-size)
+	 -1)  ; error result
+	(else
+	 (if (>= *next-index* (vector-length *memory*))
+	     (let ((new (make-vector (* 2 (vector-length *memory*)))))
+	       (do ((i 0 (+ i 1)))
+		   ((>= i (vector-length *memory*)))
+		 (vector-set! new i (vector-ref *memory* i)))
+	       (set! *memory* new)))
+	 (let ((index *next-index*))
+	   (set! *next-index* (+ *next-index* 1))
+	   (vector-set! *memory* index (make-code-vector size 0))
+	   (make-address (arithmetic-shift index log-max-size))))))
+
+; Turning an address into a page or page index
+
+(define (address->vector address)
+  (vector-ref *memory* (arithmetic-shift address address-shift)))
+
+(define (address->vector-index address)
+  (bitwise-and address address-mask))
+
+; Throw away the page containing ADDRESS, which must be the first address in
+; that page, 
+
+(define (deallocate-memory address)
+  (let ((address (address-index address)))
+    (let ((vector (address->vector address))
+	  (byte-address (address->vector-index address)))
+      (if (and vector (= byte-address 0))
+	  (vector-set! *memory* (arithmetic-shift address address-shift) #f)
+	  (error "bad deallocation address" address)))))
+
+; Various ways of accessing memory
+
+(define (unsigned-byte-ref address)
+  (let ((address (address-index address)))
+    (code-vector-ref (address->vector address)
+		     (address->vector-index address))))
+
+(define (signed-code-vector-ref bvec i)
+  (let ((x (code-vector-ref bvec i)))
+    (if (< x 128)
+	x
+	(bitwise-ior x -128))))
+
+(define (word-ref address)
+  (let ((address (address-index address)))
+    (let ((vector (address->vector address))
+	  (byte-address (address->vector-index address)))
+      (if (not (= 0 (bitwise-and byte-address 3)))
+	  (error "unaligned address error" address)
+	  (+ (+ (arithmetic-shift (signed-code-vector-ref vector byte-address) 24)
+		(arithmetic-shift (code-vector-ref vector (+ byte-address 1)) 16))
+	     (+ (arithmetic-shift (code-vector-ref vector (+ byte-address 2))  8)
+		(code-vector-ref vector (+ byte-address 3))))))))
+  
+(define (unsigned-byte-set! address value)
+  (let ((address (address-index address)))
+    (code-vector-set! (address->vector address)
+		      (address->vector-index address)
+		      (bitwise-and 255 value))))
+	    
+(define (word-set! address value)
+  (let ((address (address-index address)))
+    (let ((vector (address->vector address))
+	  (byte-address (address->vector-index address)))
+      (if (not (= 0 (bitwise-and byte-address 3)))
+	  (error "unaligned address error" address))
+      (code-vector-set! vector    byte-address
+			(bitwise-and 255 (arithmetic-shift value -24)))
+      (code-vector-set! vector (+ byte-address 1)
+			(bitwise-and 255 (arithmetic-shift value -16)))
+      (code-vector-set! vector (+ byte-address 2)
+			(bitwise-and 255 (arithmetic-shift value -8)))
+      (code-vector-set! vector (+ byte-address 3)
+			(bitwise-and 255 value)))))
+
+; Block I/O procedures.
+
+(define (write-block port address count)
+  (let ((address (address-index address)))
+    (let ((vector (address->vector address))
+	  (byte-address (address->vector-index address)))
+      (do ((i 0 (+ i 1)))
+	  ((>= i count))
+	(write-char (ascii->char (code-vector-ref vector (+ i byte-address)))
+		    port))
+      (enum errors no-errors))))
+
+(define (read-block port address count)
+  (let ((address (address-index address)))
+    (cond ((not (char-ready? port))
+	   (values 0 #f (enum errors no-errors)))
+	  ((eof-object? (s-peek-char port))
+	   (values 0 #t (enum errors no-errors)))
+	  (else
+	   (let ((vector (address->vector address))
+		 (byte-address (address->vector-index address)))
+	     (let loop ((i 0))
+	       (if (or (= i count)
+		       (not (char-ready? port)))
+		   (values i #f (enum errors no-errors))
+		   (let ((c (s-read-char port)))
+		     (cond ((eof-object? c)
+			    (values i #f (enum errors no-errors)))
+			   (else
+			    (code-vector-set! vector
+					      (+ i byte-address)
+					      (char->ascii c))
+			    (loop (+ i 1))))))))))))
+
+(define (copy-memory! from to count)
+  (let ((from (address-index from))
+	(to (address-index to)))
+    (let ((from-vector (address->vector from))
+	  (from-address (address->vector-index from))
+	  (to-vector (address->vector to))
+	  (to-address (address->vector-index to)))
+      (do ((i 0 (+ i 1)))
+	  ((>= i count))
+	(code-vector-set! to-vector
+			  (+ i to-address)
+			  (code-vector-ref from-vector
+					   (+ i from-address)))))))
+
+(define (memory-equal? from to count)
+  (let ((from (address-index from))
+	(to (address-index to)))
+    (let ((from-vector (address->vector from))
+	  (from-address (address->vector-index from))
+	  (to-vector (address->vector to))
+	  (to-address (address->vector-index to)))
+      (let loop ((i 0))
+	(cond ((>= i count)
+	       #t)
+	      ((= (code-vector-ref to-vector (+ i to-address))
+		  (code-vector-ref from-vector (+ i from-address)))
+	       (loop (+ i 1)))
+	      (else
+	       #f))))))
+
+; Turn the LENGTH bytes starting from ADDRESS into a string.
+
+(define (char-pointer->string address length)
+  (let ((address (address-index address)))
+    (let ((vector (address->vector address))
+	  (byte-address (address->vector-index address))
+	  (string (make-string length)))
+      (do ((i 0 (+ i 1)))
+	  ((= i length))
+	(string-set! string
+		     i
+		     (ascii->char (code-vector-ref vector (+ byte-address i)))))
+      string)))
+
+; Turn the bytes from ADDRESS to the next nul (byte equal to 0) into a
+; string.  This is a trivial operation in C.
+
+(define (char-pointer->nul-terminated-string address)
+  (let ((index (address-index address)))
+    (let ((vector (address->vector index))
+	  (byte-address (address->vector-index index)))
+      (char-pointer->string address (index-of-first-nul vector byte-address)))))
+  
+(define (index-of-first-nul vector address)
+  (let loop ((i address))
+    (cond ((= i (code-vector-length vector))
+	   (error "CHAR-POINTER->STRING called on pointer with no nul termination"))
+	  ((= 0 (code-vector-ref vector i))
+	   (- i address))
+	  (else
+	   (loop (+ i 1))))))
+	  
diff --git a/scheme/prescheme/memory2.scm b/scheme/prescheme/memory2.scm
new file mode 100644
index 0000000..ddd890a
--- /dev/null
+++ b/scheme/prescheme/memory2.scm
@@ -0,0 +1,244 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; An implementation of Pre-Scheme's memory interface that can detect some
+; stray reads and writes.  It has numerous limitiations:
+;    Allocations are always on page boundaries.
+;    No more than 16 megabytes can be allocated at once.
+;    More than 32 or 64 or so allocations result in addresses being
+;       bignums (dealloctions have no effect on this).
+;
+; Memory is represented as a vector of byte-vectors, with each byte-vector
+; representing a 16-megabyte page.  Allocations are always made on page
+; boundaries, so the byte-vectors only need be as large as the allocated
+; areas.  Pages are never re-used.
+
+; Memory is one big vector, with markers at beginning and end of free blocks
+; and allocationg by by address ordered first fit.
+
+; Strings and things end up as bignums...
+
+(define *memory* (make-vector 0 0))
+
+(define-record-type address :address
+  (make-address index)
+  address?
+  (index address-index))
+  
+(define-record-discloser :address
+  (lambda (addr) (list 'address (address-index addr))))
+
+; We add 100000000 to addresses to make them
+
+(define address-offset 100000000)
+
+(define (address->integer addr)
+  (+ (address-index addr) address-offset))
+
+(define (integer->address int)
+  (make-address (- int address-offset)))
+
+(define (word-ref addr)
+  (if (address? addr)
+      (let ((index (address-index addr)))
+	(if (and (= 0
+  (vector-ref *memory* (address-index addr)))
+
+(define (word-ref addr)
+  (vector-ref *memory* (address-index addr)))
+
+
+
+
+
+
+
+
+
+(define *memory* (make-vector 16 #f))    ; vector of pages
+(define log-max-size 24)                 ; log of page size
+(define address-shift (- log-max-size))  ; turns addresses into page indices
+
+(define max-size (arithmetic-shift 1 log-max-size))  ; page size
+
+(define address-mask                     ; mask to get address within page
+  (- (arithmetic-shift 1 log-max-size) 1))
+
+(define *next-index* 0)                  ; next available page
+
+(define (reinitialize-memory)
+  (set! *memory* (make-vector 16 #f))
+  (set! *next-index* 0))
+
+; Extend the page vector if necessary, and then make a page of the
+; appropriate size.
+
+(define (allocate-memory size)
+  (cond ((> size max-size)
+	 #f)  ; the null pointer
+	(else
+	 (if (>= *next-index* (vector-length *memory*))
+	     (let ((new (make-vector (* 2 (vector-length *memory*)))))
+	       (do ((i 0 (+ i 1)))
+		   ((>= i (vector-length *memory*)))
+		 (vector-set! new i (vector-ref *memory* i)))
+	       (set! *memory* new)))
+	 (let ((index *next-index*))
+	   (set! *next-index* (+ *next-index* 1))
+	   (vector-set! *memory* index (make-code-vector size 0))
+	   (arithmetic-shift index log-max-size)))))
+
+; Turning an address into a page or page index
+
+(define (address->vector address)
+  (vector-ref *memory* (arithmetic-shift address address-shift)))
+
+(define (address->vector-index address)
+  (bitwise-and address address-mask))
+
+; Throw away the page containing ADDRESS, which must be the first address in
+; that page, 
+
+(define (deallocate-memory address)
+  (let ((vector (address->vector address))
+	(byte-address (address->vector-index address)))
+    (if (and vector (= byte-address 0))
+	(vector-set! *memory* (arithmetic-shift address address-shift) #f)
+	(error "bad deallocation address" address))))
+
+; Various ways of accessing memory
+
+(define (unsigned-byte-ref address)
+  (code-vector-ref (address->vector address)
+		   (address->vector-index address)))
+
+(define (signed-code-vector-ref bvec i)
+  (let ((x (code-vector-ref bvec i)))
+    (if (< x 128)
+	x
+	(bitwise-ior x -128))))
+
+(define (word-ref address)
+  (let ((vector (address->vector address))
+	(byte-address (address->vector-index address)))
+    (if (not (= 0 (bitwise-and byte-address 3)))
+	(error "unaligned address error" address)
+	(+ (+ (arithmetic-shift (signed-code-vector-ref vector byte-address) 24)
+	      (arithmetic-shift (code-vector-ref vector (+ byte-address 1)) 16))
+	   (+ (arithmetic-shift (code-vector-ref vector (+ byte-address 2))  8)
+	      (code-vector-ref vector (+ byte-address 3)))))))
+	    
+(define (unsigned-byte-set! address value)
+  (code-vector-set! (address->vector address)
+		    (address->vector-index address)
+		    (bitwise-and 255 value)))
+	    
+(define (word-set! address value)
+  (let ((vector (address->vector address))
+	(byte-address (address->vector-index address)))
+    (if (not (= 0 (bitwise-and byte-address 3)))
+	(error "unaligned address error" address))
+    (code-vector-set! vector    byte-address
+		      (bitwise-and 255 (arithmetic-shift value -24)))
+    (code-vector-set! vector (+ byte-address 1)
+		      (bitwise-and 255 (arithmetic-shift value -16)))
+    (code-vector-set! vector (+ byte-address 2)
+		      (bitwise-and 255 (arithmetic-shift value -8)))
+    (code-vector-set! vector (+ byte-address 3)
+		      (bitwise-and 255 value))))
+
+; Block I/O procedures.
+
+(define (write-block port address count)
+  (let ((vector (address->vector address))
+	(byte-address (address->vector-index address)))
+    (do ((i 0 (+ i 1)))
+	((>= i count))
+      (write-char (ascii->char (code-vector-ref vector (+ i byte-address)))
+		  port))
+    (values count (enum errors no-errors))))
+
+(define (read-block port address count)
+  (cond ((not (char-ready? port))
+	 (values 0 #f (enum errors no-errors)))
+	((eof-object? (s-peek-char port))
+	 (values 0 #t (enum errors no-errors)))
+	(else
+	 (let ((vector (address->vector address))
+	       (byte-address (address->vector-index address)))
+	   (let loop ((i 0))
+	     (if (or (= i count)
+		     (not (char-ready? port)))
+		 (values i #f (enum errors no-errors))
+		 (let ((c (s-read-char port)))
+		   (cond ((eof-object? c)
+			  (values i #f (enum errors no-errors)))
+			 (else
+			  (code-vector-set! vector
+					    (+ i byte-address)
+					    (char->ascii c))
+			  (loop (+ i 1)))))))))))
+
+(define (copy-memory! from to count)
+  (let ((from-vector (address->vector from))
+	(from-address (address->vector-index from))
+	(to-vector (address->vector to))
+	(to-address (address->vector-index to)))
+    (do ((i 0 (+ i 1)))
+	((>= i count))
+      (code-vector-set! to-vector
+			(+ i to-address)
+			(code-vector-ref from-vector
+					 (+ i from-address))))))
+
+(define (memory-equal? from to count)
+  (let ((from-vector (address->vector from))
+	(from-address (address->vector-index from))
+	(to-vector (address->vector to))
+	(to-address (address->vector-index to)))
+    (let loop ((i 0))
+      (cond ((>= i count)
+	     #t)
+	    ((= (code-vector-ref to-vector (+ i to-address))
+		(code-vector-ref from-vector (+ i from-address)))
+	     (loop (+ i 1)))
+	    (else
+	     #f)))))
+
+; Turn the LENGTH bytes starting from ADDRESS into a string.
+
+(define (char-pointer->string address length)
+  (let ((vector (address->vector address))
+	(byte-address (address->vector-index address))
+	(string (make-string length)))
+    (do ((i 0 (+ i 1)))
+	((= i length))
+      (string-set! string
+		   i
+		   (ascii->char (code-vector-ref vector (+ byte-address i)))))
+    string))
+
+; Turn the bytes from ADDRESS to the next nul (byte equal to 0) into a
+; string.  This is a trivial operation in C.
+
+(define (char-pointer->nul-terminated-string address)
+  (let ((vector (address->vector address))
+	(byte-address (address->vector-index address)))
+    (char-pointer->string address (index-of-first-nul vector byte-address))))
+
+(define (index-of-first-nul vector address)
+  (let loop ((i address))
+    (cond ((= i (code-vector-length vector))
+	   (error "CHAR-POINTER->STRING called on pointer with no nul termination"))
+	  ((= 0 (code-vector-ref vector i))
+	   (- i address))
+	  (else
+	   (loop (+ i 1))))))
+	  
+; We really need these to work.
+
+(define address+ +)
+(define address- -)
+(define address-difference -)
+(define address->integer identity)
+(define integer->address identity)
+(define ...)
diff --git a/scheme/prescheme/package-defs.scm b/scheme/prescheme/package-defs.scm
new file mode 100644
index 0000000..29efb0f
--- /dev/null
+++ b/scheme/prescheme/package-defs.scm
@@ -0,0 +1,38 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+(define-structures ((prescheme prescheme-interface)
+		    (ps-memory ps-memory-interface)
+		    (memory-debug (export reinitialize-memory))
+		    (ps-receive ps-receive-interface)
+		    (external-constants (export make-external-constant
+						external-constant?
+						external-constant-enum-name
+						external-constant-name
+						external-constant-c-string)))
+  (open scheme code-vectors bitwise ascii primitives signals enumerated
+	structure-refs
+	define-record-types
+	bigbit)   ; make sure that bignum bitwise operations are loaded
+  (access scheme)
+  (optimize auto-integrate)
+  (begin
+    ; What we will get in C on many machines
+    (define pre-scheme-integer-size 32))
+  (files ps-defenum prescheme memory))
+
+;(define-structure byte-vectors byte-vector-interface
+;  (open scheme code-vectors)
+;  (optimize auto-integrate)
+;  (files byte-vector))
+;
+;(define-interface byte-vector-interface
+;  (export make-byte-vector
+;          byte-vector?
+;          byte-vector-ref byte-vector-set!
+;          signed-byte-vector-ref signed-byte-vector-set!
+;          byte-vector-ref32 byte-vector-set32!
+;          signed-byte-vector-ref32 signed-byte-vector-set32!))
+;
+;(define-structure xmemory ps-memory-interface
+;  (open scheme byte-vectors signals enumerated bitwise)
+;  (files simple-memory))
\ No newline at end of file
diff --git a/scheme/prescheme/prescheme.scm b/scheme/prescheme/prescheme.scm
new file mode 100644
index 0000000..6a0d760
--- /dev/null
+++ b/scheme/prescheme/prescheme.scm
@@ -0,0 +1,138 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Stuff in Pre-Scheme that is not in Scheme.
+
+(define shift-left arithmetic-shift)
+
+(define (arithmetic-shift-right i n)
+  (arithmetic-shift i (- 0 n)))
+
+; Hack for the robots
+(define small* *) ; could do a range check
+
+(define int-mask (- (arithmetic-shift 1 pre-scheme-integer-size) 1))
+
+(define (logical-shift-right i n)
+  (if (>= i 0)
+      (arithmetic-shift i (- 0 n))
+      (arithmetic-shift (bitwise-and i int-mask) (- 0 n))))
+
+(define (deallocate x) #f)
+(define (null-pointer? x) (not x))
+
+(define-external-enumeration errors
+  (no-errors
+   (parse-error    "EDOM")
+   (file-not-found "ENOENT")
+   (out-of-memory  "ENOMEM")
+   (invalid-port   "EBADF")
+   ))
+
+(define (error-string status)
+  "an error")
+  ; (symbol->string (enumerand->name status errors)))
+
+(define (open-input-file name)
+  (let ((port ((structure-ref scheme open-input-file) name)))
+    (values port
+	    (if port
+		(enum errors no-errors)
+		(enum errors file-not-found)))))
+
+(define (open-output-file name)
+  (let ((port ((structure-ref scheme open-output-file) name)))
+    (values port
+	    (if port
+		(enum errors no-errors)
+		(enum errors file-not-found)))))
+
+(define (close-input-port port)
+  ((structure-ref scheme close-input-port) port)
+  (enum errors no-errors))
+
+(define (close-output-port port)
+  ((structure-ref scheme close-output-port) port)
+  (enum errors no-errors))
+
+(define (read-char port)
+  (let ((ch (s-read-char port)))
+    (if (eof-object? ch)
+	(values (ascii->char 0) #t (enum errors no-errors))
+	(values ch #f (enum errors no-errors)))))
+
+(define (peek-char port)
+  (let ((ch (s-peek-char port)))
+    (if (eof-object? ch)
+	(values (ascii->char 0) #t (enum errors no-errors))
+	(values ch #f (enum errors no-errors)))))
+
+(define s-read-char (structure-ref scheme read-char))
+(define s-peek-char (structure-ref scheme peek-char))
+
+(define (read-integer port)
+  (eat-whitespace! port)
+  (let ((neg? (let ((x (s-peek-char port)))
+		(if (eof-object? x)
+		    #f
+		    (case x
+		      ((#\+) (s-read-char port) #f)
+		      ((#\-) (s-read-char port) #t)
+		      (else #f))))))
+    (let loop ((n 0) (any? #f))
+      (let ((x (s-peek-char port)))
+	(cond ((and (char? x)
+		    (char-numeric? x))
+	       (s-read-char port)
+	       (loop (+ (* n 10)
+			(- (char->integer x)
+			   (char->integer #\0)))
+		     #t))
+	      (any?
+	       (values (if neg? (- n) n) #f (enum errors no-errors)))
+	      ((eof-object? x)
+	       (values 0 #t (enum errors no-errors)))
+	      (else
+	       (values 0 #f (enum errors parse-error))))))))
+
+(define (eat-whitespace! port)
+  (cond ((char-whitespace? (s-peek-char port))
+	 (s-read-char port)
+	 (eat-whitespace! port))))
+
+(define (write-x string port)
+  (display string port)
+  (enum errors no-errors))
+
+(define write-char write-x)
+(define write-string write-x)
+(define write-integer write-x)
+
+(define (force-output port)
+  (enum errors no-errors))
+
+(define (newline port)
+  (write-char #\newline port)
+  (enum errors no-errors))
+
+(define-syntax goto
+  (lambda (exp rename compare)
+    (cdr exp)))
+
+; (external <string> <type> . <maybe scheme value>)
+
+(define-syntax external
+  (lambda (exp rename compare)
+    (if (null? (cdddr exp))
+	exp
+	(cadddr exp))))
+
+(define current-error-port current-output-port)
+
+; RECEIVE (from big-scheme)
+
+(define-syntax receive
+  (syntax-rules ()
+    ((receive ?vars ?producer . ?body)
+     (call-with-values (lambda () ?producer)
+		       (lambda ?vars . ?body)))))
diff --git a/scheme/prescheme/ps-defenum.scm b/scheme/prescheme/ps-defenum.scm
new file mode 100644
index 0000000..8097aa2
--- /dev/null
+++ b/scheme/prescheme/ps-defenum.scm
@@ -0,0 +1,98 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; DEFINE-ENUMERATION macro hacked to use external (C enumeration) names
+; instead of integers.
+
+;(define-external-enumeration bing
+;  ((foo "BAR")
+;   baz))
+;  =>
+;(define-syntax bing ...)
+;(define bing/foo (make-external-constant 'bing 'foo "BAR"))
+;(define bing/baz (make-external-constant 'bing 'baz "BAZ"))
+;
+;(enum bing foo) => bing/foo
+
+(define-record-type external-constant :external-constant
+  (make-external-constant enum-name name c-string)
+  external-constant?
+  (enum-name external-constant-enum-name)
+  (name external-constant-name)
+  (c-string external-constant-c-string))
+
+(define-record-discloser :external-constant
+  (lambda (external-const)
+    (list 'enum
+	  (external-constant-enum-name external-const)
+	  (external-constant-name external-const))))
+
+(define-syntax define-external-enumeration
+  (lambda (form rename compare)
+    (let* ((name (cadr form))
+	   (symbol->upcase-string
+	    (lambda (s)
+	      (list->string (map (lambda (c)
+				   (if (char=? c #\-)
+				       #\_
+				       (char-upcase c)))
+				 (string->list (symbol->string s))))))
+	   (constant
+	    (lambda (sym string)
+	      `(,(rename 'make-external-constant) ',name ',sym ,string)))
+	   (conc (lambda things
+		   (string->symbol (apply string-append
+					  (map (lambda (thing)
+						 (if (symbol? thing)
+						     (symbol->string thing)
+						     thing))
+					       things)))))
+	   (var-name
+	    (lambda (sym)
+	      (conc name "/" sym)))
+	   (components
+	    (list->vector
+	     (map (lambda (stuff)
+		    (if (pair? stuff)
+			(cons (car stuff)
+			      (var-name (car stuff)))
+			(cons stuff
+			      (var-name stuff))))
+		  (caddr form))))
+	   (%define (rename 'define))
+	   (%define-syntax (rename 'define-syntax))
+	   (%begin (rename 'begin))
+	   (%quote (rename 'quote))
+	   (%make-external-constant (rename 'make-external-constant))
+	   (e-name (conc name '- 'enumeration))
+	   (count (vector-length components)))
+      `(,%begin
+	(,%define-syntax ,name
+	    (let ((components ',components))
+	      (lambda (e r c)
+		(let ((key (cadr e)))
+		  (cond ((c key 'enum)
+			 (let ((which (caddr e)))
+			   (let loop ((i 0)) ;vector-posq
+			     (if (< i ,count)
+				 (if (c which (car (vector-ref components i)))
+				     (r (cdr (vector-ref components i)))
+				     (loop (+ i 1)))
+				 ;; (syntax-error "unknown enumerand name"
+				 ;;               `(,(cadr e) ,(car e) ,(caddr e)))
+				 e))))
+			(else e))))))
+	(,%define ,(conc name '- 'count) ,count)
+        . ,(map (lambda (stuff)
+		  (if (pair? stuff)
+		      `(,%define ,(var-name (car stuff))
+			   (,%make-external-constant ',name
+						     ',(car stuff)
+						     ,(cadr stuff)))
+		      `(,%define ,(var-name stuff)
+			   (,%make-external-constant ',name
+						     ',stuff
+						     ,(symbol->upcase-string stuff)))))
+		(caddr form)))))
+    (begin define define-syntax quote external make-external-constant))
+
+
diff --git a/scheme/rts-packages.scm b/scheme/rts-packages.scm
new file mode 100644
index 0000000..6266b58
--- /dev/null
+++ b/scheme/rts-packages.scm
@@ -0,0 +1,332 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+(define-structures ((scheme-level-1 scheme-level-1-interface)
+		    (util util-interface))
+  (open scheme-level-0 ascii signals)
+  (usual-transforms case quasiquote syntax-rules)
+  (files (rts base)
+	 (rts util)
+	 (rts number)
+	 (rts lize))	  ; Rationalize
+  (optimize auto-integrate))
+
+
+; "Level 2"
+
+(define-structures ((records records-interface)
+		    (records-internal records-internal-interface))
+  (open scheme-level-1 signals
+	primitives)
+  (files (rts record))
+  (optimize auto-integrate))
+
+; The external code needs this to check the types of records.
+
+(define-structure export-the-record-type (export)
+  (open scheme-level-1 records-internal shared-bindings)
+  (begin
+    (define-exported-binding "s48-the-record-type" :record-type)))
+
+(define-structure define-record-types define-record-types-interface
+  (open scheme-level-1 records records-internal loopholes
+	primitives) ; unspecific
+  (files (rts jar-defrecord)))
+
+(define-structures ((methods methods-interface)
+		    (meta-methods meta-methods-interface))
+  (open scheme-level-1
+	define-record-types
+	records records-internal
+	bitwise util primitives
+	signals)
+  (files (rts method))
+  (optimize auto-integrate))
+
+(define-structure number-i/o number-i/o-interface
+  (open scheme-level-1 methods signals ascii)
+  (files (rts numio)))
+
+(define-structures ((fluids fluids-interface)
+		    (fluids-internal fluids-internal-interface))
+  (open scheme-level-1 define-record-types primitives)
+  (files (rts fluid))
+  (optimize auto-integrate))
+
+(define-structure wind wind-interface
+  (open scheme-level-1 signals define-record-types
+	fluids fluids-internal
+	escapes)
+  (files (rts wind))
+  (optimize auto-integrate))
+
+(define-structure session-data (export make-session-data-slot!
+				       initialize-session-data!
+				       session-data-ref
+				       session-data-set!)
+  (open scheme-level-1
+	primitives)
+  (files (rts session))
+  (optimize auto-integrate))
+
+(define-structures ((i/o i/o-interface)
+		    (i/o-internal i/o-internal-interface))
+  (open scheme-level-1 signals fluids
+	architecture
+	primitives ports code-vectors bitwise
+	define-record-types ascii
+	threads locks
+	methods         ; &disclose :input-port :output-port
+	interrupts      ; {en|dis}able-interrupts!
+	number-i/o      ; number->string for debugging
+	exceptions      ; wrong-number-of-args stuff
+	handle)		; report-errors-as-warnings
+  (files (rts port)
+	 (rts current-port))
+  (optimize auto-integrate))
+
+(define-structure channels channels-interface
+  (open scheme-level-1
+	low-channels
+	architecture
+	signals)	; error, call-error
+  (files (rts channel)))
+
+(define-structure channel-i/o channel-i/o-interface
+  (open scheme-level-1 i/o i/o-internal signals
+	channels low-channels
+	architecture code-vectors wind
+	define-record-types
+	queues threads threads-internal locks
+	exceptions interrupts
+	ascii ports util
+	session-data
+	structure-refs
+	debug-messages	; for error messages
+	handle)		; report-errors-as-warnings
+  (access primitives)	; add-finalizer, channel stuff
+  (files (rts channel-port)
+	 (rts channel-io)))
+
+(define-structure conditions conditions-interface
+  (open scheme-level-1 signals)
+  (files (rts condition)))
+
+(define-structure writing writing-interface
+  (open scheme-level-1
+	number-i/o
+	i/o				;output-port-option, write-string
+	methods				;disclose
+	structure-refs)
+  (access low-channels			;channel? channel-id
+	  code-vectors)			;code-vector?
+  (files (rts write)))
+	 
+(define-structure reading reading-interface
+  (open scheme-level-1
+	number-i/o
+	i/o		;input-port-option
+	ascii		;for dispatch table
+	signals		;warn, signal-condition, make-condition
+	conditions	;define-condition-type
+	primitives	;make-immutable!
+	silly)		;reverse-list->string
+  (files (rts read))
+  (optimize auto-integrate))
+
+(define-structure scheme-level-2 scheme-level-2-interface
+  (open scheme-level-1
+	number-i/o
+	writing
+	reading
+	wind
+	i/o
+	channel-i/o))
+
+(define-structure features features-interface
+  (open primitives i/o))
+
+; Hairier stuff now.
+
+(define-structure templates templates-interface
+  (open scheme-level-1 primitives methods)
+  (files (rts template))
+  (optimize auto-integrate))
+
+(define-structure continuations continuations-interface
+  (open scheme-level-1 primitives templates methods architecture code-vectors)
+  (files (rts continuation))
+  (optimize auto-integrate))
+
+(define-structure more-types (export :closure :code-vector :location :double
+				     :template :channel :port :weak-pointer
+				     :shared-binding)
+  (open scheme-level-1 methods
+	closures code-vectors locations templates low-channels ports primitives
+	shared-bindings)
+  (begin (define-simple-type :closure     (:value) closure?)
+	 (define-simple-type :code-vector (:value) code-vector?)
+	 (define-simple-type :location    (:value) location?)
+	 (define-simple-type :template    (:value) template?)
+	 (define-simple-type :channel     (:value) channel?)
+	 (define-simple-type :port        (:value) port?)
+	 (define-simple-type :double      (:rational) double?)
+	 (define-simple-type :weak-pointer (:value) weak-pointer?)
+	 (define-method &disclose ((obj :weak-pointer)) (list 'weak-pointer))
+	 (define-simple-type :shared-binding (:value) shared-binding?)
+	 (define-method &disclose ((obj :shared-binding))
+	   (list (if (shared-binding-is-import? obj)
+		     'imported-binding
+		     'exported-binding)
+		 (shared-binding-name obj)))))
+
+(define-structure enumerated enumerated-interface
+  (open scheme-level-1 signals)
+  (files (rts defenum scm)))
+
+(define-structure architecture architecture-interface
+  (open scheme-level-1 signals enumerated)
+  (files (vm arch)))
+
+(define-structures ((exceptions exceptions-interface)
+		    (handle handle-interface))
+  (open scheme-level-1
+	signals fluids
+	conditions	  ;make-exception, etc.
+	primitives	  ;set-exception-handlers!, etc.
+	wind		  ;CWCC
+	methods
+	meta-methods
+	more-types
+	architecture
+	vm-exposure	  ;primitive-catch
+	templates	  ;template-code, template-info
+	continuations	  ;continuation-pc, etc.
+	locations	  ;location?, location-id
+	closures	  ;closure-template
+	number-i/o)       ; number->string, for backtrace
+  (files (rts exception)))  ; Needs generic, arch
+
+(define-structure interrupts interrupts-interface
+  (open scheme-level-1
+	signals fluids conditions
+	bitwise
+	escapes
+	session-data
+	primitives
+	architecture)
+  (files (rts interrupt))
+  (optimize auto-integrate)) ;mostly for threads package...
+
+(define-structures ((threads threads-interface)
+		    (threads-internal threads-internal-interface))
+  (open scheme-level-1 enumerated define-record-types queues
+	interrupts
+        wind
+        fluids
+	fluids-internal         ;get-dynamic-env
+        escapes                 ;primitive-cwcc
+        conditions              ;error?
+        handle                  ;with-handler
+        signals                 ;signal, warn
+	loopholes               ;for converting #f to a continuation
+	architecture            ;time-option
+	session-data
+	debug-messages
+	structure-refs)
+  (access primitives)           ;time current-thread set-current-thread! etc.
+  (optimize auto-integrate)
+  (files (rts thread) (rts sleep)))
+
+(define-structure scheduler scheduler-interface
+  (open scheme-level-1 threads threads-internal enumerated enum-case
+	debug-messages
+	signals)       		;error
+  (files (rts scheduler)))
+
+(define-structure root-scheduler (export root-scheduler
+					 spawn-on-root
+					 scheme-exit-now
+					 call-when-deadlocked!)
+  (open scheme-level-1 threads threads-internal scheduler structure-refs
+	session-data
+	signals        		;error
+	handle			;with-handler
+	i/o			;current-error-port
+	conditions		;warning?, error?
+	writing			;display
+	i/o-internal            ;output-port-forcer, output-forcer-id
+	fluids-internal         ;get-dynamic-env
+	interrupts              ;with-interrupts-inhibited
+	wind                    ;call-with-current-continuation
+	channel-i/o)		;waiting-for-i/o?
+  (access primitives)		;unspecific, wait
+  (files (rts root-scheduler)))
+
+(define-structure enum-case (export (enum-case :syntax))
+  (open scheme-level-1 enumerated util)
+  (begin
+    (define-syntax enum-case
+      (syntax-rules (else)
+	((enum-case enumeration (x ...) clause ...)
+	 (let ((temp (x ...)))
+	   (enum-case enumeration temp clause ...)))
+	((enum-case enumeration value ((name ...) body ...) rest ...)
+	 (if (or (= value (enum enumeration name)) ...)
+	     (begin body ...)
+	     (enum-case enumeration value rest ...)))
+	((enum-case enumeration value (else body ...))
+	 (begin body ...))
+	((enum-case enumeration value)
+	 (unspecific))))))
+
+(define-structure queues queues-interface
+  (open scheme-level-1 define-record-types signals)
+  (files (big queue))
+  (optimize auto-integrate))
+
+; No longer used
+;(define-structure linked-queues (compound-interface 
+;                                 queues-interface
+;                                 (export delete-queue-entry!
+;                                         queue-head))
+;  (open scheme-level-1 define-record-types signals primitives)
+;  (files (big linked-queue))
+;  (optimize auto-integrate))
+
+(define-structure locks locks-interface
+  (open scheme-level-1 define-record-types interrupts threads threads-internal)
+  (optimize auto-integrate)
+  (files (rts lock)))
+
+(define-structure usual-resumer (export usual-resumer)
+  (open scheme-level-1
+	i/o		 ;initialize-i/o, etc.
+	channel-i/o      ;{in,out}put-channel->port, initialize-channel-i/o
+	session-data     ;initialize-session-data!
+	fluids-internal	 ;initialize-dynamic-state!
+	exceptions	 ;initialize-exceptions!
+	interrupts	 ;initialize-interrupts!
+	records-internal ;initialize-records!
+	export-the-record-type	;just what it says
+	threads-internal ;start threads
+	root-scheduler)  ;start a scheduler
+  (files (rts init)))
+
+; Weak pointers & populations
+
+(define-structure weak weak-interface
+  (open scheme-level-1 signals
+	primitives)	;Open primitives instead of loading (alt weak)
+  (files ;;(alt weak)   ;Only needed if VM's weak pointers are buggy
+	 (rts population)))
+
+
+; Utility for displaying error messages
+
+(define-structure display-conditions display-conditions-interface
+  (open scheme-level-2
+	writing
+	methods
+	handle)			;ignore-errors
+  (files (env dispcond)))
diff --git a/scheme/rts/base.scm b/scheme/rts/base.scm
new file mode 100644
index 0000000..e3cfe73
--- /dev/null
+++ b/scheme/rts/base.scm
@@ -0,0 +1,424 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This is file base.scm.
+
+;;;; Fundamental definitions
+
+; Order of appearance is approximately that of the Revised^4 Report.
+
+; Booleans
+
+(define (not x) (if x #f #t))
+(define (boolean? x) (or (eq? x #t) (eq? x #f)))
+
+; Equality
+
+(define (eqv? x y)
+  (or (eq? x y)
+      (and (number? x)
+           (number? y)
+           (eq? (exact? x) (exact? y))
+           (= x y))))
+
+(define (equal? obj1 obj2)
+  (cond ((eqv? obj1 obj2) #t)
+        ((pair? obj1)
+         (and (pair? obj2)
+              (equal? (car obj1) (car obj2))
+              (equal? (cdr obj1) (cdr obj2))))
+        ((string? obj1)
+         (and (string? obj2)
+              (string=? obj1 obj2)))
+        ((vector? obj1)
+         (and (vector? obj2)
+              (let ((z (vector-length obj1)))
+                (and (= z (vector-length obj2))
+                     (let loop ((i 0))
+                       (cond ((= i z) #t)
+                             ((equal? (vector-ref obj1 i) (vector-ref obj2 i))
+                              (loop (+ i 1)))
+                             (else #f)))))))
+        (else #f)))
+
+; Messy because of inexact contagion.
+
+(define (max first . rest)
+  (max-or-min first rest #t))
+
+(define (min first . rest)
+  (max-or-min first rest #f))
+
+(define (max-or-min first rest max?)
+  (let loop ((result first) (rest rest) (lose? (inexact? first)))
+    (if (null? rest)
+	(if (and lose? (exact? result))
+	    (exact->inexact result)
+	    result)
+	(let ((next (car rest)))
+	  (loop (if (if max?
+			(< result next)
+			(> result next))
+		    next
+		    result)
+		(cdr rest)
+		(or lose? (inexact? next)))))))
+
+(define (abs n) (if (< n 0) (- 0 n) n))
+
+(define (zero? x) (= x 0))
+(define (positive? x) (< 0 x))
+(define (negative? x) (< x 0))
+
+(define (even? n) (= 0 (remainder n 2)))
+(define (odd? n) (not (even? n)))
+
+; Lists
+
+(define (caar   x) (car (car x)))
+(define (cadr   x) (car (cdr x)))
+(define (cdar   x) (cdr (car x)))
+(define (cddr   x) (cdr (cdr x)))
+
+(define (caaar  x) (caar (car x)))
+(define (caadr  x) (caar (cdr x)))
+(define (cadar  x) (cadr (car x)))
+(define (caddr  x) (cadr (cdr x)))
+(define (cdaar  x) (cdar (car x)))
+(define (cdadr  x) (cdar (cdr x)))
+(define (cddar  x) (cddr (car x)))
+(define (cdddr  x) (cddr (cdr x)))
+
+(define (caaaar x) (caaar (car x)))
+(define (caaadr x) (caaar (cdr x)))
+(define (caadar x) (caadr (car x)))
+(define (caaddr x) (caadr (cdr x)))
+(define (cadaar x) (cadar (car x)))
+(define (cadadr x) (cadar (cdr x)))
+(define (caddar x) (caddr (car x)))
+(define (cadddr x) (caddr (cdr x)))
+(define (cdaaar x) (cdaar (car x)))
+(define (cdaadr x) (cdaar (cdr x)))
+(define (cdadar x) (cdadr (car x)))
+(define (cdaddr x) (cdadr (cdr x)))
+(define (cddaar x) (cddar (car x)))
+(define (cddadr x) (cddar (cdr x)))
+(define (cdddar x) (cdddr (car x)))
+(define (cddddr x) (cdddr (cdr x)))
+
+(define (null? x) (eq? x '()))
+
+(define (list . l) l)
+
+;(define (length l)
+;  (reduce (lambda (ignore n) (+ n 1)) 0 l))
+
+; Bummed version.  Pretend that you didn't see this.
+
+(define (length l)
+  (real-length l 0))
+
+(define (real-length l r)
+  (if (null? l)
+      r
+      (real-length (cdr l) (+ r 1))))
+
+(define (append . lists)
+  (if (null? lists)
+      '()
+      (let recur ((lists lists))
+	(if (null? (cdr lists))
+	    (car lists)
+	    (reduce cons (recur (cdr lists)) (car lists))))))
+
+(define (reverse list)
+  (append-reverse list '()))
+
+(define (append-reverse list seed)
+  (if (null? list)
+      seed
+      (append-reverse (cdr list) (cons (car list) seed))))
+
+(define (list-tail l i)
+  (cond ((= i 0) l)
+	(else (list-tail (cdr l) (- i 1)))))
+
+(define (list-ref l k)
+  (car (list-tail l k)))
+
+(define (mem pred)
+  (lambda (obj l)
+    (let loop ((l l))
+      (cond ((null? l) #f)
+	    ((pred obj (car l)) l)
+	    (else (loop (cdr l)))))))
+
+(define memq   (mem eq?))
+(define memv   (mem eqv?))
+(define member (mem equal?))
+
+(define (ass pred)
+  (lambda (obj l)
+    (let loop ((l l))
+      (cond ((null? l) #f)
+            ((pred obj (caar l)) (car l))
+            (else (loop (cdr l)))))))
+
+;(define assq  (ass eq?))  ; done by VM for speed
+(define assv  (ass eqv?))
+(define assoc (ass equal?))
+
+(define (list? l)			;New in R4RS
+  (let recur ((l l) (lag l))		;Cycle detection
+    (or (null? l)
+	(and (pair? l)
+	     (or (null? (cdr l))
+		 (and (pair? (cdr l))
+		      (not (eq? (cdr l) lag))
+		      (recur (cddr l) (cdr lag))))))))
+
+; Characters
+
+(define (char>? x y) (char<? y x))
+(define (char>=? x y) (not (char<? x y)))
+(define (char<=? x y) (not (char>? x y)))
+
+(define (char-whitespace? c)
+  (if (memq (char->ascii c) ascii-whitespaces) #t #f))
+
+(define (char-lower-case? c)
+  (and (char>=? c #\a)
+       (char<=? c #\z)))
+
+(define (char-upper-case? c)
+  (and (char>=? c #\A)
+       (char<=? c #\Z)))
+
+(define (char-numeric? c)
+  (and (char>=? c #\0)
+       (char<=? c #\9)))
+
+(define (char-alphabetic? c)
+  (or (char-upper-case? c)
+      (char-lower-case? c)))
+
+(define char-case-delta 
+  (- (char->ascii #\a) (char->ascii #\A)))
+
+(define (make-character-map f)
+  (let ((s (make-string ascii-limit #\0)))
+    (do ((i 0 (+ i 1)))
+	((>= i ascii-limit))
+      (string-set! s i (f (ascii->char i))))
+    s))
+
+(define upcase-map
+  (make-character-map
+   (lambda (c)
+     (if (char-lower-case? c)
+	 (ascii->char (- (char->ascii c) char-case-delta))
+	 c))))
+
+(define (char-upcase c)
+  (string-ref upcase-map (char->ascii c)))
+
+(define downcase-map
+  (make-character-map
+   (lambda (c)
+     (if (char-upper-case? c)
+	 (ascii->char (+ (char->ascii c) char-case-delta))
+	 c))))
+
+(define (char-downcase c)
+  (string-ref downcase-map (char->ascii c)))
+
+(define (char-ci-compare pred)
+  (lambda (c1 c2) (pred (char-upcase c1) (char-upcase c2))))
+(define char-ci=? (char-ci-compare char=?))
+(define char-ci<? (char-ci-compare char<?))
+(define char-ci<=? (char-ci-compare char<=?))
+(define char-ci>? (char-ci-compare char>?))
+(define char-ci>=? (char-ci-compare char>=?))
+
+
+; Strings
+
+(define (string . rest)
+  (list->string rest))
+
+(define (substring s start end)
+  (let ((new-string (make-string (- end start) #\space)))
+    (do ((i start (+ i 1))
+         (j 0 (+ j 1)))
+        ((= i end) new-string)
+      (string-set! new-string j (string-ref s i)))))
+
+(define (string-append  . strings)
+  (let ((len (reduce (lambda (s n) (+ (string-length s) n)) 0 strings)))
+    (let ((new-string (make-string len #\space)))
+      (let loop ((s strings)
+		 (i 0))
+	(if (null? s)
+	    new-string
+	    (let* ((string (car s))
+		   (l (string-length string)))
+	      (do ((j 0 (+ j 1))
+		   (i i (+ i 1)))
+		  ((= j l) (loop (cdr s) i))
+		(string-set! new-string i (string-ref string j)))))))))
+
+(define (string->list v)
+  (let ((z (string-length v)))
+    (do ((i (- z 1) (- i 1))
+         (l '() (cons (string-ref v i) l)))
+        ((< i 0) l))))
+
+(define (list->string l)
+  (let ((v (make-string (length l) #\space)))
+    (do ((i 0 (+ i 1))
+         (l l (cdr l)))
+        ((null? l) v)
+      (string-set! v i (car l)))))
+
+; comes from low-level package ...
+;(define (string-copy s)
+;  (let ((z (string-length s)))
+;    (let ((copy (make-string z #\space)))
+;      (let loop ((i 0))
+;        (cond ((= i z) copy)
+;              (else
+;               (string-set! copy i (string-ref s i))
+;               (loop (+ i 1))))))))
+
+(define (string-fill! v x)
+  (let ((z (string-length v)))
+    (do ((i 0 (+ i 1)))
+        ((= i z) (unspecific))
+      (string-set! v i x))))
+
+(define (make-string=? char=?)
+  (lambda (s1 s2)
+    (let ((z (string-length s1)))
+      (and (= z (string-length s2))
+	   (let loop ((i 0))
+	     (cond ((= i z) #t)
+		   ((char=? (string-ref s1 i) (string-ref s2 i))
+		    (loop (+ i 1)))
+		   (else #f)))))))
+
+;(define string=?    (make-string=? char=?))  -- VM implements this
+(define string-ci=? (make-string=? char-ci=?))
+
+(define (make-string<? char<? char=?)
+  (lambda (s1 s2)
+    (let ((z1 (string-length s1))
+	  (z2 (string-length s2)))
+      (let ((z (min z1 z2)))
+	(let loop ((i 0))
+	  (if (= i z)
+	      (< z1 z2)
+	      (let ((c1 (string-ref s1 i))
+		    (c2 (string-ref s2 i)))
+		(or (char<? c1 c2)
+		    (and (char=? c1 c2)
+			 (loop (+ i 1)))))))))))
+
+(define string<?    (make-string<? char<? char=?))
+(define string-ci<? (make-string<? char-ci<? char-ci=?))
+
+(define (string>? s1 s2) (string<? s2 s1))
+(define (string<=? s1 s2) (not (string>? s1 s2)))
+(define (string>=? s1 s2) (not (string<? s1 s2)))
+
+(define (string-ci>? s1 s2) (string-ci<? s2 s1))
+(define (string-ci<=? s1 s2) (not (string-ci>? s1 s2)))
+(define (string-ci>=? s1 s2) (not (string-ci<? s1 s2)))
+
+; Vectors
+
+;(define (vector . l)   ; now an opcode for efficiency
+;  (list->vector l))
+
+(define (vector->list v)
+  (do ((i (- (vector-length v) 1) (- i 1))
+       (l '() (cons (vector-ref v i) l)))
+      ((< i 0) l)))
+
+(define (list->vector l)
+  (let ((v (make-vector (length l) #f)))
+    (do ((i 0 (+ i 1))
+         (l l (cdr l)))
+        ((null? l) v)
+      (vector-set! v i (car l)))))
+
+(define (vector-fill! v x)
+  (let ((z (vector-length v)))
+    (do ((i 0 (+ i 1)))
+        ((= i z) (unspecific))
+      (vector-set! v i x))))
+
+; Control features
+
+(define (map proc first . rest)
+  (if (null? rest)
+      (map1 proc first)
+      (map2+ proc first rest)))
+
+(define (map1 proc l)
+  ;; (reduce (lambda (x l) (cons (proc x) l)) '() l)
+  (if (null? l)
+      '()
+      (cons (proc (car l)) (map1 proc (cdr l)))))
+
+(define (map2+ proc first rest)
+  (if (or (null? first)
+	  (any null? rest))
+      '()
+      (cons (apply proc (cons (car first) (map1 car rest)))
+	    (map2+ proc (cdr first) (map1 cdr rest)))))
+
+(define (for-each proc first . rest)
+  (if (null? rest)
+      (for-each1 proc first)
+      (for-each2+ proc first rest)))
+
+(define (for-each1 proc first)
+  (let loop ((first first))
+    (if (null? first)
+	(unspecific)
+	(begin (proc (car first))
+	       (loop (cdr first))))))
+
+(define (for-each2+ proc first rest)
+  (let loop ((first first) (rest rest))
+    (if (or (null? first)
+	    (any null? rest))
+	(unspecific)
+	(begin (apply proc (cons (car first) (map car rest)))
+	       (loop (cdr first) (map cdr rest))))))
+
+
+; Promises, promises.
+
+(define-syntax delay
+  (syntax-rules ()
+    ((delay ?exp) (make-promise (lambda () ?exp)))))
+
+; A slightly modified copy of the code from R4RS; the modification ensures
+; that the thunk is GC'ed after the promise is evaluted.
+; JAR writes: "It is not for us to judge the wisdom of the new definition."
+
+(define (make-promise thunk-then-result)
+  (let ((already-run? #f))
+    (lambda ()
+      (if already-run?                         ; can't be interrupted from now
+	  thunk-then-result
+	  (let ((result (thunk-then-result)))  ; until after this call
+	    (cond ((not already-run?)
+		   (set! already-run? #t)
+		   (set! thunk-then-result result)))
+	    thunk-then-result)))))
+
+(define (force promise)
+  (promise))
diff --git a/scheme/rts/bignum.scm b/scheme/rts/bignum.scm
new file mode 100644
index 0000000..24aa98f
--- /dev/null
+++ b/scheme/rts/bignum.scm
@@ -0,0 +1,343 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; This is file bignum.scm.
+
+; Integer arithmetic
+
+(define-extended-number-type :bignum (:exact-integer)
+  (make-bignum sign magnitude)
+  bignum?
+  (sign bignum-sign)
+  (magnitude bignum-magnitude))
+
+(define (integer->bignum m)
+  (if (bignum? m)
+      m
+      (cond ((>= m 0)
+	     (make-bignum 1 (integer->magnitude m)))
+	    ((= m least-non-bignum)
+	     (make-bignum -1 least-non-bignum-magnitude))
+	    (else
+	     (make-bignum -1 (integer->magnitude (- 0 m)))))))
+
+;(define (bignum->integer n)             ;For debugging
+;  (* (bignum-sign n)
+;     (reduce (lambda (d n) (+ d (* n radix)))
+;             0
+;             (bignum-magnitude n))))
+
+(define (make-integer sign mag)
+  (if (> sign 0)
+      (if (smaller-magnitude? greatest-non-bignum-magnitude mag)
+	  (make-bignum sign mag)
+	  (magnitude->integer mag))
+      (if (smaller-magnitude? least-non-bignum-magnitude mag)
+	  (make-bignum sign mag)
+	  (if (same-magnitude? mag least-non-bignum-magnitude)
+	      least-non-bignum
+	      (- 0 (magnitude->integer mag))))))
+
+; Arithmetic
+
+(define (integer+ m n)
+  (let ((m (integer->bignum m))
+	(n (integer->bignum n)))
+    (let ((m-sign (bignum-sign m))
+	  (m-mag (bignum-magnitude m))
+	  (n-sign (bignum-sign n))
+	  (n-mag (bignum-magnitude n)))
+    (if (= m-sign n-sign)
+	(make-integer m-sign (add-magnitudes m-mag n-mag))
+	(if (smaller-magnitude? m-mag n-mag)
+	    (make-integer (- 0 m-sign) (subtract-magnitudes n-mag m-mag))
+	    (make-integer m-sign (subtract-magnitudes m-mag n-mag)))))))
+
+(define (integer- m n)
+  (integer+ m (integer-negate n)))
+
+(define (integer-negate m)
+  (cond ((bignum? m)
+	 (make-integer (- 0 (bignum-sign m))
+		       (bignum-magnitude m)))
+	((= m least-non-bignum)
+	 (make-bignum 1 least-non-bignum-magnitude))
+	(else (- 0 m))))
+
+(define (integer* m n)
+  (let ((m (integer->bignum m))
+	(n (integer->bignum n)))
+    (make-integer (* (bignum-sign m) (bignum-sign n))
+		  (multiply-magnitudes
+		   (bignum-magnitude m)
+		   (bignum-magnitude n)))))
+
+(define (integer-divide m n cont)
+  (let ((m (integer->bignum m))
+	(n (integer->bignum n)))
+    (divide-magnitudes
+       (bignum-magnitude m)
+       (bignum-magnitude n)
+       (lambda (q r)
+	 (cont (make-integer (* (bignum-sign m) (bignum-sign n)) q)
+	       (make-integer (bignum-sign m) r))))))
+
+(define (integer-quotient m n)
+  (integer-divide m n (lambda (q r) q)))
+
+(define (integer-remainder m n)
+  (integer-divide m n (lambda (q r) r)))
+
+(define integer=
+  (lambda (m n)
+    (let ((m (integer->bignum m))
+	  (n (integer->bignum n)))
+      (and (= (bignum-sign m) (bignum-sign n))
+	   (same-magnitude? (bignum-magnitude m)
+			    (bignum-magnitude n))))))
+
+(define integer<
+  (lambda (m n)
+    (let ((m (integer->bignum m))
+	  (n (integer->bignum n)))
+      (let ((m-sign (bignum-sign m))
+	    (n-sign (bignum-sign n)))
+	(or (< m-sign n-sign)
+	    (and (= m-sign n-sign)
+		 (if (< m-sign 0)
+		     (smaller-magnitude? (bignum-magnitude n)
+					 (bignum-magnitude m))
+		     (smaller-magnitude? (bignum-magnitude m)
+					 (bignum-magnitude n)))))))))
+
+
+; Magnitude (unsigned integer) arithmetic
+
+(define log-radix 14)			;Cutting it close here...
+(define radix (expt 2 log-radix))
+
+(define greatest-non-bignum (+ (expt 2 28) (- (expt 2 28) 1)))
+(define least-non-bignum (* (expt 2 28) -2))
+
+(define zero-magnitude '())
+(define zero-magnitude? null?)
+
+(define (low-digit m)
+  (if (zero-magnitude? m)
+      0
+      (car m)))
+
+(define (high-digits m)
+  (if (zero-magnitude? m)
+      m
+      (cdr m)))
+
+(define (adjoin-digit d m)
+  (if (and (= d 0) (zero-magnitude? m))
+      m
+      (cons d m)))
+
+(define (integer->magnitude n)
+  (if (= n 0)
+      zero-magnitude
+      (let ((digit (remainder n radix)))
+	(adjoin-digit digit
+		      (integer->magnitude (quotient n radix))))))
+
+(define (magnitude->integer m)
+  (if (zero-magnitude? m)
+      0
+      (+ (low-digit m)
+	 (* radix (magnitude->integer (high-digits m))))))
+
+(define greatest-non-bignum-magnitude
+  (integer->magnitude greatest-non-bignum))
+
+(define least-non-bignum-magnitude
+  (adjoin-digit (- 0 (remainder least-non-bignum radix))
+		(integer->magnitude
+		 (- 0 (quotient least-non-bignum radix)))))
+
+; Combine two numbers digitwise using op.
+
+(define (combine-magnitudes m n op)
+  (let recur ((m m) (n n) (carry 0))
+    (if (and (zero-magnitude? m) (zero-magnitude? n))
+	(integer->magnitude carry)
+	(let ((result (+ carry (op (low-digit m) (low-digit n)))))
+	  (let ((q (quotient result radix))
+		(r (remainder result radix)))
+	    (if (< r 0)
+		(adjoin-digit (+ r radix)
+			      (recur (high-digits m)
+				     (high-digits n)
+				     (- q 1)))
+		(adjoin-digit r
+			      (recur (high-digits m)
+				     (high-digits n)
+				     q))))))))
+
+(define (add-magnitudes m n)
+  (combine-magnitudes m n +))
+
+(define (subtract-magnitudes m n)
+  (combine-magnitudes m n -))
+
+; Compare
+
+(define same-magnitude? equal?)
+
+(define (smaller-magnitude? m n)
+  (let ((m-len (length m))
+	(n-len (length n)))
+    (cond ((< m-len n-len)
+	   #t)
+	  ((< n-len m-len)
+	   #f)
+	  (else
+	   (let loop ((m m) (n n) (a #f))
+	     (cond ((zero-magnitude? m)
+		    (or (not (zero-magnitude? n)) a))
+		   ((zero-magnitude? n) #f)
+		   (else
+		    (loop (high-digits m)
+			  (high-digits n)
+			  (or (< (low-digit m) (low-digit n))
+			      (and (= (low-digit m) (low-digit n)) a))))))))))
+
+; Multiply
+
+(define (multiply-magnitudes m n)
+  (let recur ((m m) (a zero-magnitude))
+    (if (zero-magnitude? m)
+	a
+	(let ((a (combine-magnitudes a n (lambda (d e)
+					   (+ d (* e (low-digit m)))))))
+	  (adjoin-digit (low-digit a)
+			(recur (high-digits m) (high-digits a)))))))
+
+; Divide m/n: find q and r such that m = q*n + r, where 0 <= r < n.
+; Oh no... time to get out Knuth...
+; The main thing we don't do that Knuth does is to normalize the
+; divisor (n) by shifting it left.
+
+(define (divide-magnitudes m n cont)
+  (if (zero-magnitude? (high-digits n))
+      (divide-by-digit m (low-digit n)
+		       (lambda (q r)
+			 (cont q (adjoin-digit r zero-magnitude))))
+      (let recur ((m m) (cont cont))
+	(if (smaller-magnitude? m n)
+	    (cont zero-magnitude m)
+	    (recur
+	     (high-digits m)
+	     (lambda (q r)
+	       ;; 0 <= r < n  and  d < b
+	       ;; so  b*r + d < b*n.
+	       (divide-step (adjoin-digit (low-digit m) r)
+			    n
+			    (lambda (q1 r)
+			      (cont (adjoin-digit q1 q) r)))))))))
+	
+; Divide m by n, where  n <= m < b*n, i.e. 1 <= quotient < b.
+; E.g.  if  n = 100  then  100 <= m <= 999
+;       if  n = 999  then  999 <= m <= 9989
+
+(define (divide-step m n cont)
+  (do ((m-high m (high-digits m-high))
+       (n-high n (high-digits n-high)))
+      ((zero-magnitude? (high-digits (high-digits n-high)))
+       ;; Occasionally q^ is one larger than the actual first digit.
+       ;; This loop will never iterate more than once.
+       (let loop ((q^ (min (guess-quotient-digit m-high n-high)
+			   (- radix 1))))
+	 (let ((r (combine-magnitudes m n (lambda (d e)
+					    (- d (* e q^))))))
+	   (if (improper-magnitude? r)
+	       ;; (begin (write `(addback ,m ,n ,q^ ,r)) (newline) ...)
+	       (loop (- q^ 1))
+	       (cont q^ r)))))))
+
+; Compute q such that [m1 m2 m3] = q*[n1 n2] + r with 0 <= r < [n1 n2]
+; Can assume b <= [0 n1 n2] <= [m1 m2 m3] <= [n1 n2 b-1]
+; Some examples:
+;  m / n :  100[1] / 10[02], 099 / 10, 099[1] / 99[0], 999[8] / 99[99]
+; Various hacks are possible to improve performance.  In particular, the
+; second division can be eliminated if the divisor is normalized.
+; See Knuth.
+;  [m1 m2] = q0*[n1] + r0
+;  [m1 m2 m3] = q0*[n1 n2] + r^
+;  r^ = b*r0 + m3 - q0*n2
+
+(define (guess-quotient-digit m n)
+  (let ((n1 (low-digit (high-digits n)))
+	(n2 (low-digit n))
+	(m1 (low-digit (high-digits (high-digits m))))
+	(m2 (low-digit (high-digits m)))
+	(m3 (low-digit m)))
+    (let ((m12 (+ (* m1 radix) m2)))
+      (let ((q0 (quotient m12 n1))
+	    (r0 (remainder m12 n1)))
+	(let ((r^ (- (+ (* radix r0) m3) (* q0 n2)))
+	      (n12 (+ (* n1 radix) n2)))
+	  (let ((q1 (quotient r^ n12))
+		(r1 (remainder r^ n12)))
+	    (if (> q1 0)
+		(begin (display "This should never happen: q1 = ")
+		       (write q1) (newline)))
+	    (let ((q (+ q0 q1)))
+	      (if (< r1 0) (- q 1) q))))))))
+
+(define (improper-magnitude? m)
+  (and (not (zero-magnitude? m))
+       (or (< (low-digit m) 0)
+	   (improper-magnitude? (high-digits m)))))
+
+; Special case of division algorithm for single-digit divisor.
+
+(define (divide-by-digit m d cont)
+  (if (= d 0)
+      (error "integer division by zero" m d)
+      (let recur ((m m) (cont cont))
+	(if (and (zero-magnitude? (high-digits m))
+		 (< (low-digit m) d))
+	    (cont zero-magnitude (low-digit m))
+	    (recur (high-digits m)
+		   (lambda (q r)
+		     (let ((m1 (+ (low-digit m) (* radix r))))
+		       (cont (adjoin-digit (quotient m1 d) q)
+			     (remainder m1 d)))))))))
+
+;(define (divide-test seed)
+;  (let ((random (make-random seed)))
+;    (let loop ()
+;      (let* ((z1 (integer+ (random) (integer* (random) 10000000)))
+;             (z2 (integer+ (random) (integer* (random) 10000000)))
+;             (n (max z1 z2))
+;             (r (min z1 z2))
+;             (q (random))
+;             (m (integer+ (integer* n q) r)))
+;        (if (not (= n r))
+;            (integer-divide m n
+;                            (lambda (q1 r1)
+;                              (if (and (= q q1) (= r r1))
+;                                  (begin (display ".")
+;                                         (force-output (current-output-port)))
+;                                  (error "division error" m n q q1 r r1)))))
+;        (loop)))))
+
+
+; Extend the generic arithmetic operators.
+
+(define-method &integer? ((n :bignum)) #t)
+(define-method &exact? ((n :bignum)) #t)
+
+(define-method &+ ((n1 :exact-integer) (n2 :exact-integer)) (integer+ n1 n2))
+(define-method &- ((n1 :exact-integer) (n2 :exact-integer)) (integer- n1 n2))
+(define-method &* ((n1 :exact-integer) (n2 :exact-integer)) (integer* n1 n2))
+(define-method &= ((n1 :exact-integer) (n2 :exact-integer)) (integer= n1 n2))
+(define-method &< ((n1 :exact-integer) (n2 :exact-integer)) (integer< n1 n2))
+
+(define-method &quotient ((n1 :exact-integer) (n2 :exact-integer))
+  (integer-quotient n1 n2))
+(define-method &remainder ((n1 :exact-integer) (n2 :exact-integer))
+  (integer-remainder n1 n2))
diff --git a/scheme/rts/channel-io.scm b/scheme/rts/channel-io.scm
new file mode 100644
index 0000000..8571794
--- /dev/null
+++ b/scheme/rts/channel-io.scm
@@ -0,0 +1,160 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Channel interrupt stuff.
+
+; Install an interrupt handler that queues up the results of completed I/O
+; operations and spawn a thread to cope with them.  This is written so as
+; to avoid having state in top-level variables, because their values are
+; saved in dumped images.
+
+(define (initialize-channel-i/o!)
+  (session-data-set! channel-wait-queues-slot '())
+  (session-data-set! channel-wait-count-slot 0)
+  (set-interrupt-handler! (enum interrupt i/o-completion)
+			  i/o-completion-handler))
+
+; The warning message is printed using DEBUG-MESSAGE because to try to make
+; sure it appears in spite of whatever problem's the I/O system is having.
+;
+; Called with interrupts disabled.
+
+(define (i/o-completion-handler channel status enabled-interrupts)
+  (let ((queue (fetch-channel-wait-queue! channel)))
+    (if queue
+	(begin
+	  (decrement-channel-wait-count!)
+	  (make-ready (dequeue-thread! queue) status))
+	(debug-message "Warning: dropping ignored channel i/o result {Channel "
+		       (channel-os-index channel)
+		       " "
+		       (channel-id channel)
+		       "}"))))
+
+; Exported procedure
+
+(define (waiting-for-i/o?)
+  (< 0 (channel-wait-count)))
+
+; Block until the current I/O operation on CHANNEL has completed.
+; This returns the result of the operation.
+;
+; This needs to be called with interrupts disabled.
+;
+; We install a DYNAMIC-WIND to abort the operation if the waiting thread is
+; terminated.
+
+(define (wait-for-channel channel)
+  (let ((queue (fetch-channel-wait-queue! channel)))
+    (if queue
+	(begin
+	  (add-channel-wait-queue! channel queue)
+	  (warn "channel has two pending operations" channel)
+	  (terminate-current-thread))
+	(let ((queue (make-thread-queue)))
+	  (increment-channel-wait-count!)
+	  (enqueue-thread! queue (current-thread))
+	  (add-channel-wait-queue! channel queue)
+	  (dynamic-wind nothing
+			block
+			(lambda ()
+			  (disable-interrupts!)
+			  (let ((new-queue (fetch-channel-wait-queue! channel)))
+			    (cond ((eq? queue new-queue)
+				   (channel-abort channel)
+				   (wait-for-channel channel))
+				  (new-queue
+				   (add-channel-wait-queue! channel new-queue)))
+			    (enable-interrupts!))))))))
+
+(define (nothing) #f)
+
+; Abort any pending operation on by OWNER on CHANNEL.
+; Called with interrupts disabled.
+  
+(define (steal-channel! channel owner)
+  (let ((queue (fetch-channel-wait-queue! channel)))
+    (if queue
+	(let ((thread (dequeue-thread! queue)))
+	  (cond ((eq? thread owner)
+		 (decrement-channel-wait-count!)
+                 (channel-abort channel))
+		(else
+		 (warn "channel in use by other than port owner" channel)
+		 (enqueue-thread! queue thread)
+		 #f)))
+	#f)))
+
+; Have CHANNEL-READ and CHANNEL-WRITE wait if a pending-channel-i/o
+; exception occurs.
+
+(define-exception-handler (enum op channel-maybe-read)
+  (lambda (opcode reason buffer start count wait? channel . maybe-os-message)
+    (if (= reason (enum exception pending-channel-i/o))
+	(wait-for-channel channel)
+	(begin
+	  (enable-interrupts!)
+ 	  (apply signal-exception
+ 		 opcode reason buffer start count wait? channel
+ 		 maybe-os-message)))))
+
+(define-exception-handler (enum op channel-maybe-write)
+  (lambda (opcode reason buffer start count channel . maybe-os-message)
+    (if (= reason (enum exception pending-channel-i/o))
+	(wait-for-channel channel)
+	(begin
+	  (enable-interrupts!)
+ 	  (apply signal-exception
+ 		 opcode reason buffer start count channel
+ 		 maybe-os-message)))))
+
+; Two session slots
+;   - the number of threads waiting for I/O completion events
+;   - an alist mapping channels to queues for waiting threads
+
+(define channel-wait-count-slot (make-session-data-slot! 0))
+
+(define (channel-wait-count)
+  (session-data-ref channel-wait-count-slot))
+
+(define (increment-channel-wait-count!)
+  (session-data-set! channel-wait-count-slot (+ (channel-wait-count) 1)))
+
+(define (decrement-channel-wait-count!)
+  (session-data-set! channel-wait-count-slot (- (channel-wait-count) 1)))
+
+(define channel-wait-queues-slot (make-session-data-slot! '()))
+
+; Adding a queue and channel - the caller has already determined there is no
+; existing queue for this channel.
+
+(define (add-channel-wait-queue! channel queue)
+  (session-data-set! channel-wait-queues-slot
+		     (cons (cons channel queue)
+			   (session-data-ref channel-wait-queues-slot))))
+
+; This is just deleting from an a-list.
+
+(define (fetch-channel-wait-queue! channel)
+  (let* ((queues (session-data-ref channel-wait-queues-slot))
+	 (queue (cond ((null? queues)
+		       #f)
+		      ((eq? channel (caar queues))
+		       (session-data-set! channel-wait-queues-slot
+					  (cdr queues))
+		       (cdar queues))
+		      (else
+		       (let loop ((queues (cdr queues)) (prev queues))
+			 (cond ((null? queues)
+				#f)
+			       ((eq? channel (caar queues))
+				(set-cdr! prev (cdr queues))
+				(cdar queues))
+			       (else
+				(loop (cdr queues) queues))))))))
+    (if (or (not queue)
+	    (thread-queue-empty? queue))
+	#f
+	queue)))
+  
+
+  
diff --git a/scheme/rts/channel-port.scm b/scheme/rts/channel-port.scm
new file mode 100644
index 0000000..35922f0
--- /dev/null
+++ b/scheme/rts/channel-port.scm
@@ -0,0 +1,228 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Ports built on OS channels.
+;
+; We wrap the channels in a record so that we can distinguish these ports
+; from others.
+
+; Repeatedly calls CHANNEL-READ until enough characters have been obtained.
+; There are three different conditions under which the buffer-procedure
+; is called:
+;  1) any number of characters is fine, but an immediate response is
+;     needed (the originating procedure was CHAR-READY?)
+;  2) wait for at least one character, but not after that (from READ-CHAR)
+;  3) exactly NEEDED characters are required (from READ-BLOCK)
+
+(define input-channel-handler
+  (make-port-handler
+   (lambda (channel-cell)
+     (list 'input-port (channel-cell-ref channel-cell)))
+   (lambda (channel-cell)
+     ((channel-cell-closer channel-cell)
+        (channel-cell-ref channel-cell)))
+   (lambda (channel-cell buffer start needed)
+     (channel-read buffer start needed (channel-cell-ref channel-cell)))))
+
+(define (input-channel->port channel . maybe-buffer-size)
+  (real-input-channel->port channel maybe-buffer-size close-input-channel))
+
+; This is for sockets, which have their own closing mechanism.
+
+(define (input-channel+closer->port channel closer . maybe-buffer-size)
+  (real-input-channel->port channel maybe-buffer-size closer))
+	     
+(define (real-input-channel->port channel maybe-buffer-size closer)
+  (let ((buffer-size (if (null? maybe-buffer-size)
+			 default-buffer-size
+			 (car maybe-buffer-size))))
+    (if (>= 0 buffer-size)
+	(call-error "invalid buffer size" input-channel->port channel buffer-size)
+	(make-input-port input-channel-handler
+			 (make-channel-cell channel closer)
+			 (make-code-vector buffer-size 0)
+			 0
+			 0))))
+  
+(define output-channel-handler
+  (make-port-handler
+   (lambda (channel-cell)
+     (list 'output-port (channel-cell-ref channel-cell)))
+   (lambda (channel-cell)
+     ((channel-cell-closer channel-cell)
+        (channel-cell-ref channel-cell)))
+   (lambda (channel-cell buffer start count)
+     (channel-write buffer start count (channel-cell-ref channel-cell)))))
+
+; Unbuffered channel output ports.  Used for the default error port.
+
+(define (make-unbuffered-output-channel-handler)
+  (let ((buffer (make-code-vector 1 0)))
+    (make-port-handler
+     (lambda (channel-cell)
+       (list 'output-port (channel-cell-ref channel-cell)))
+     (lambda (channel-cell)
+       ((channel-cell-closer channel-cell)
+          (channel-cell-ref channel-cell)))
+     (lambda (channel-cell char)
+       (code-vector-set! buffer 0 (char->ascii char))
+       (channel-write buffer 0 1 (channel-cell-ref channel-cell))))))
+
+; Dispatch on the buffer size to make the appropriate port.  A buffer
+; size of zero creates an unbuffered port.  Buffered output ports get a
+; finalizer to flush the buffer if the port is GC'ed.
+
+(define (output-channel->port channel . maybe-buffer-size)
+  (real-output-channel->port channel maybe-buffer-size close-output-channel))
+
+; This is for sockets, which have their own closing mechanism.
+
+(define (output-channel+closer->port channel closer . maybe-buffer-size)
+  (real-output-channel->port channel maybe-buffer-size closer))
+	     
+(define (real-output-channel->port channel maybe-buffer-size closer)
+  (let ((buffer-size (if (null? maybe-buffer-size)
+			 default-buffer-size
+			 (car maybe-buffer-size))))
+    (cond ((> 0 buffer-size)
+	   (call-error "invalid buffer size"
+		       output-channel->port channel buffer-size))
+	  ((= 0 buffer-size)
+	   (make-unbuffered-output-port (make-unbuffered-output-channel-handler)
+					(make-channel-cell channel closer)))
+	  (else
+	   (let ((port (make-output-port output-channel-handler
+					 (make-channel-cell channel closer)
+					 (make-code-vector buffer-size 0)
+					 0
+					 buffer-size)))
+	     (periodically-force-output! port)
+	     ((structure-ref primitives add-finalizer!) port
+							maybe-force-output)
+	     port)))))
+	     
+; Flush PORT's output buffer if the port is open and not locked.
+
+(define (maybe-force-output port)
+  (cond ((maybe-obtain-lock (port-lock port))
+	 (report-errors-as-warnings (lambda ()
+				      (really-force-output port))
+				    "error while flushing GC'ed port's buffer"
+				    port)
+	 (release-lock (port-lock port)))))
+
+;----------------
+; The records we use to mark channel ports and the function that makes use of
+; them.
+
+(define-record-type channel-cell :channel-cell
+  (make-channel-cell channel closer)
+  channel-cell?
+  (channel channel-cell-ref)
+  (closer channel-cell-closer))
+
+(define (port->channel port)
+  (let ((data (port-data port)))
+    (if (channel-cell? data)
+	(channel-cell-ref data)
+	#f)))
+
+;----------------
+; Various ways to open ports on files.
+
+(define (open-input-file string)
+  (if (string? string)
+      (input-channel->port (open-input-channel string))
+      (call-error "invalid argument" open-input-file string)))
+
+(define (open-output-file string)
+  (if (string? string)
+      (output-channel->port (open-output-channel string))
+      (call-error "invalid argument" open-output-file string)))
+
+(define (call-with-input-file string proc)
+  (let* ((port (open-input-file string))
+         (results (call-with-values (lambda () (proc port))
+				    list)))
+    (close-input-port port)
+    (apply values results)))
+
+(define (call-with-output-file string proc)
+  (let* ((port (open-output-file string))
+         (results (call-with-values (lambda () (proc port))
+				    list)))
+    (close-output-port port)
+    (apply values results)))
+
+(define (with-input-from-file string thunk)
+  (call-with-input-file string
+    (lambda (port)
+      (call-with-current-input-port port thunk))))
+
+(define (with-output-to-file string thunk)
+  (call-with-output-file string
+    (lambda (port)
+      (call-with-current-output-port port thunk))))
+
+;----------------
+; Flush the output buffers of all channel output ports.  This is done before
+; forking the current process.
+
+(define (force-channel-output-ports!)
+  (for-each (lambda (port)
+	      (if (port->channel port)
+		  (force-output-if-open port)))
+	    (periodically-flushed-ports)))
+
+;----------------
+; The following is used to make the REPL's input, output, and error ports
+; available after a keyboard interrupt.  If PORT is a locked channel port
+; we save the its state and then reinitialize it.  The OS is told to
+; abort any pending operation on the port's channel.  Finally, the owning
+; thread's continuation is munged to restore the port when the thread
+; resumes.  Any buffered input is thrown away at that point (it could
+; be saved away with the channel).
+;
+; If the port is locked by us or one of our ancestors there is no point in
+; trying to grab it.
+
+(define (steal-channel-port! port)
+  (if (port->channel port)
+      (begin
+	(disable-interrupts!)
+	(let ((owner (if (lock-owner-uid (port-lock port))
+			 (thread-uid->thread (lock-owner-uid (port-lock port)))
+			 #f)))
+	  (if (and owner
+		   (not (running? owner)))
+	      (really-steal-channel-port! port owner))
+	  (enable-interrupts!)))))
+
+(define (really-steal-channel-port! port owner)
+  (let ((lock (port-lock port))
+	(buffer (port-buffer port))
+	(index (port-index port))
+	(limit (port-limit port))
+	(eof? (port-pending-eof? port))
+	(status (steal-channel! (port->channel port) owner)))
+    (set-port-buffer! port (make-code-vector (code-vector-length buffer) 0))
+    (set-port-index! port 0)
+    (set-port-limit! port (if (input-port? port) 0 (code-vector-length buffer)))
+    (set-port-pending-eof?! port #f)
+    (set-port-locked?! port #f)
+    (set-port-lock! port (make-lock))
+    (interrupt-thread owner
+		      (lambda results
+			(obtain-port-lock port)
+			(cond ((output-port? port)
+			       (really-force-output port))
+			      ((< (port-index port)
+				  (port-limit port))
+			       (warn "dropping input from port" port)))
+			(set-port-buffer! port buffer)
+			(set-port-index! port index)
+			(set-port-limit! port limit)
+			(set-port-pending-eof?! port eof?)
+			(set-port-lock! port lock)
+			(or status (apply values results))))
+    ; if we took OWNER off a channel-wait queue we need to make it ready to run
+    (if status (make-ready owner))))
diff --git a/scheme/rts/channel.scm b/scheme/rts/channel.scm
new file mode 100644
index 0000000..c123d67
--- /dev/null
+++ b/scheme/rts/channel.scm
@@ -0,0 +1,39 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Provides input and output channels.
+
+(define (input-channel? thing)
+  (and (channel? thing)
+       (or (= (channel-status thing)
+	      (enum channel-status-option input))
+	   (= (channel-status thing)
+	      (enum channel-status-option special-input)))))
+
+(define (output-channel? thing)
+  (and (channel? thing)
+       (or (= (channel-status thing)
+	      (enum channel-status-option output))
+	   (= (channel-status thing)
+	      (enum channel-status-option special-output)))))
+
+(define (open-input-channel filename)
+  (let ((channel (open-channel filename (enum channel-status-option input))))
+    (if (channel? channel)
+	channel
+	(error "cannot open input file" filename))))
+
+(define (open-output-channel filename)
+  (let ((channel (open-channel filename (enum channel-status-option output))))
+    (if (channel? channel)
+	channel
+	(error "cannot open output file" filename))))
+
+(define (close-input-channel channel)
+  (if (input-channel? channel)
+      (close-channel channel)
+      (call-error close-input-channel channel)))
+
+(define (close-output-channel channel)
+  (if (output-channel? channel)
+      (close-channel channel)
+      (call-error close-output-channel channel)))
diff --git a/scheme/rts/condition.scm b/scheme/rts/condition.scm
new file mode 100644
index 0000000..30f5fc8
--- /dev/null
+++ b/scheme/rts/condition.scm
@@ -0,0 +1,77 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This is file condition.scm.
+
+;;;; Condition hierarchy
+
+; General design copied from gnu emacs.
+
+(define *condition-types* '())
+
+(define (condition-supertypes type)
+  (assq type *condition-types*))
+
+(define (define-condition-type type supertypes)
+  (set! *condition-types*
+	(cons (cons type (apply append
+				(map (lambda (sup)
+				       (or (condition-supertypes sup)
+					   (error "unrecognized condition type"
+						  sup)))
+				     supertypes)))
+	      *condition-types*)))
+
+(define (condition-predicate name)
+  (lambda (c)
+    (and (pair? c)
+	 (let ((probe (condition-supertypes (car c))))
+	   (if probe
+	       (if (memq name probe) #t #f)
+	       #f)))))
+
+(define (condition? x)
+  (and (pair? x)
+       (list? x)
+       (condition-supertypes (car x))))
+(define condition-type car)
+(define condition-stuff cdr)
+
+
+; Errors
+
+(define-condition-type 'error '())
+(define error? (condition-predicate 'error))
+
+(define-condition-type 'call-error '(error))
+(define call-error? (condition-predicate 'call-error))
+
+(define-condition-type 'read-error '(error))
+(define read-error? (condition-predicate 'read-error))
+
+; Exceptions
+
+(define-condition-type 'exception '(error))
+(define exception? (condition-predicate 'exception))
+(define exception-opcode cadr)
+(define exception-reason caddr)
+(define exception-arguments cdddr)
+
+(define (make-exception opcode reason args)
+  (make-condition 'exception (cons opcode (cons reason args))))
+
+
+; Warnings
+
+(define-condition-type 'warning '())
+(define warning? (condition-predicate 'warning))
+
+(define-condition-type 'syntax-error '(warning))
+(define syntax-error? (condition-predicate 'syntax-error))
+
+
+; Interrupts
+
+(define-condition-type 'interrupt '())
+(define interrupt? (condition-predicate 'interrupt))
diff --git a/scheme/rts/continuation.scm b/scheme/rts/continuation.scm
new file mode 100644
index 0000000..0ab5dc4
--- /dev/null
+++ b/scheme/rts/continuation.scm
@@ -0,0 +1,83 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Continuations
+
+(define (continuation-cont                c) (continuation-ref c 0))
+(define (real-continuation-pc             c) (continuation-ref c 1))
+(define (real-continuation-template       c) (continuation-ref c 2))
+(define (continuation-env                 c) (continuation-ref c 3))
+(define (exception-continuation-pc        c) (continuation-ref c 4))
+(define (exception-continuation-template  c) (continuation-ref c 5))
+(define (exception-continuation-exception c) (continuation-ref c 6))
+
+; Exception continuations contain the state of the VM when an exception occured.
+
+(define (exception-continuation? thing)
+  (and (continuation? thing)
+       (= 0 (real-continuation-pc thing))
+       (= (enum op return-from-exception)
+	  (code-vector-ref (template-code (real-continuation-template thing))
+			   0))))
+
+(define (continuation-pc c)
+  (if (exception-continuation? c)
+      (exception-continuation-pc c)
+      (real-continuation-pc c)))
+
+(define (continuation-template c)
+  (if (exception-continuation? c)
+      (exception-continuation-template c)
+      (real-continuation-template c)))
+
+; Accessing the saved operand stack.
+
+(define normal-continuation-overhead 4)
+
+(define exception-continuation-overhead
+  (+ normal-continuation-overhead 4))
+
+(define (continuation-arg c i)
+  (continuation-ref c (+ (if (exception-continuation? c)
+			     exception-continuation-overhead
+			     normal-continuation-overhead)
+			 i)))
+
+(define (continuation-arg-count c)
+  (- (continuation-length c)
+     (if (exception-continuation? c)
+	 exception-continuation-overhead
+	 normal-continuation-overhead)))
+
+(define-simple-type :continuation (:value) continuation?)
+
+(define-method &disclose ((obj :continuation))
+  (if (exception-continuation? obj)
+      (list 'exception-continuation
+	    `(pc ,(exception-continuation-pc obj))
+	    (template-info (exception-continuation-template obj)))
+      (list 'continuation
+	    `(pc ,(continuation-pc obj))
+	    (template-info (continuation-template obj)))))
+
+; If (continuation-cont A) = B, then ignore B if the following are all true:
+;   1. (continuation-template B) = (continuation-template A)
+;   2. (continuation-pc B) > (continuation-pc A)
+;   3. (continuation-env B) = (continuation-env A)
+;                             or some parent of (continuation-env A)
+;
+; I don't think this is foolproof, but I have so far been unable to
+; contrive a situation in which it fails.  I think a double recursion of a 
+; procedure of no arguments is required, at the very least.
+
+(define (continuation-parent a)
+  (let ((b (continuation-cont a)))
+    (if (and (continuation? b)
+	     (eq? (continuation-template a) (continuation-template b))
+	     (< (continuation-pc a) (continuation-pc b))
+	     (let loop ((env (continuation-env a)))
+	       (or (eq? env (continuation-env b))
+		   (and (vector? env)
+			(loop (vector-ref env 0))))))
+	(continuation-parent b)
+	b)))
diff --git a/scheme/rts/current-port.scm b/scheme/rts/current-port.scm
new file mode 100644
index 0000000..3ecd9e8
--- /dev/null
+++ b/scheme/rts/current-port.scm
@@ -0,0 +1,65 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Current input, output, error, and noise ports.
+
+; These two ports are needed by the VM for the READ-CHAR and WRITE-CHAR
+; opcodes.
+(define $current-input-port  (enum current-port-marker current-input-port))
+(define $current-output-port (enum current-port-marker current-output-port))
+
+(define $current-error-port  (make-fluid #f))
+(define $current-noise-port  (make-fluid #f))  ; defaults to the error port
+
+(define (current-input-port)
+  (fluid $current-input-port))
+
+(define (current-output-port)
+  (fluid $current-output-port))
+
+(define (current-error-port)
+  (fluid $current-error-port))
+
+(define (current-noise-port)
+  (fluid $current-noise-port))
+
+(define (initialize-i/o input output error thunk)
+  (with-current-ports input output error thunk))
+
+(define (with-current-ports in out error thunk)
+  (let-fluids $current-input-port in
+	      $current-output-port out
+	      $current-error-port error
+	      $current-noise-port error
+    thunk))
+
+(define (call-with-current-input-port port thunk)
+  (let-fluid $current-input-port port thunk))
+
+(define (call-with-current-output-port port thunk)
+  (let-fluid $current-output-port port thunk))
+
+(define (call-with-current-noise-port port thunk)
+  (let-fluid $current-noise-port port thunk))
+
+(define (silently thunk)
+  (call-with-current-noise-port (make-null-output-port) thunk))
+
+;----------------
+; Procedures with default port arguments.
+
+(define (newline . port-option)
+  (write-char #\newline (output-port-option port-option)))
+
+(define (char-ready? . port-option)
+  (real-char-ready? (input-port-option port-option)))
+
+(define (output-port-option port-option)
+  (cond ((null? port-option) (current-output-port))
+	((null? (cdr port-option)) (car port-option))
+	(else (error "write-mumble: too many arguments" port-option))))
+
+(define (input-port-option port-option)
+  (cond ((null? port-option) (current-input-port))
+	((null? (cdr port-option)) (car port-option))
+	(else (error "read-mumble: too many arguments" port-option))))
+
diff --git a/scheme/rts/defenum.scm b/scheme/rts/defenum.scm
new file mode 100644
index 0000000..7207199
--- /dev/null
+++ b/scheme/rts/defenum.scm
@@ -0,0 +1,72 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; define-enumeration macro
+
+(define-syntax define-enumeration
+  (lambda (form rename compare)
+    (let ((name (cadr form))
+          (components (list->vector (caddr form)))
+          (conc (lambda things
+                  (string->symbol (apply string-append
+                                         (map (lambda (thing)
+                                                (if (symbol? thing)
+                                                    (symbol->string thing)
+                                                    thing))
+                                              things)))))
+          (%define (rename 'define))
+          (%define-syntax (rename 'define-syntax))
+          (%begin (rename 'begin))
+          (%quote (rename 'quote)))
+      (let ((e-name (conc name '- 'enumeration))
+            (count (vector-length components)))
+        `(,%begin (,%define-syntax ,name
+                    (cons (let ((components ',components))
+                            (lambda (e r c)
+                              (let ((key (cadr e)))
+                                (cond ((c key 'components)
+                                       (r ',e-name))
+                                      ((c key 'enum)
+                                       (let ((which (caddr e)))
+                                         (let loop ((i 0)) ;vector-posq
+                                           (if (< i ,count)
+                                               (if (c which (vector-ref components i))
+                                                   i
+                                                   (loop (+ i 1)))
+                                               ;; (syntax-error "unknown enumerand name"
+                                               ;;               `(,(cadr e) ,(car e) ,(caddr e)))
+                                               e))))
+                                      (else e)))))
+                          '(,e-name)))  ;Auxiliary binding
+                  (,%define ,e-name ',components)
+                  (,%define ,(conc name '- 'count) ,count)))))
+  (begin define define-syntax quote))
+
+
+(define-syntax components
+  (cons (lambda (e r c) `(,(cadr e) components))
+        '()))
+
+(define-syntax enum
+  (cons (lambda (e r c) `(,(cadr e) enum ,(caddr e)))
+        '()))
+
+
+(define-syntax enumerand->name
+  (syntax-rules ()
+    ((enumerand->name ?enumerand ?type)
+     (vector-ref (components ?type) ?enumerand))))
+
+(define-syntax name->enumerand
+  (syntax-rules ()
+    ((name->enumerand ?name ?type)
+     (lookup-enumerand (components ?type) ?name))))
+
+(define (lookup-enumerand components name)
+  (let ((len (vector-length components)))
+    (let loop ((i 0))                   ;vector-posq
+      (if (>= i len)
+          #f
+          (if (eq? name (vector-ref components i))
+              i
+              (loop (+ i 1)))))))
diff --git a/scheme/rts/env.scm b/scheme/rts/env.scm
new file mode 100644
index 0000000..78ca3da
--- /dev/null
+++ b/scheme/rts/env.scm
@@ -0,0 +1,108 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+
+; Accessing packages
+
+(define (environment-ref package name)
+  (carefully (package-lookup package name)
+	     (lambda (loc)
+	       (if (location-assigned? loc)
+		   (contents loc)
+		   (error "uninitialized variable" name package)))
+	     package
+	     name))
+
+(define (environment-set! package name value)
+  (let ((binding (package-lookup package name)))
+    (if (and (binding? binding)
+	     (not (variable-type? (binding-type binding))))
+	(error "invalid assignment" name package value)
+	(carefully binding
+		   (lambda (loc)
+		     (set-contents! loc value))
+		   package name))))
+
+(define (environment-define! package name value)
+  (set-contents! (package-define! package name usual-variable-type #f #f)
+		 value))
+
+(define (*structure-ref struct name)
+  (let ((binding (structure-lookup struct name #f)))
+    (if binding
+	(carefully binding contents struct name)
+	(error "structure-ref: name not exported" struct name))))
+
+(define (carefully binding action env name)
+  (cond ((not binding)
+	 (error "unbound variable" name env))
+	((not (binding? binding))
+	 (error "peculiar binding" binding name env))
+	((eq? (binding-type binding) syntax-type)
+	 (error "attempt to reference syntax as variable" name env))
+	(else
+	 (let ((loc (binding-place binding)))
+	   (if (location? loc)
+	       (if (location-defined? loc)
+		   (action loc)
+		   (error "unbound variable" name env))
+	       (error "variable has no location" name env))))))
+
+; Interaction environment
+
+(define $interaction-environment (make-fluid #f))
+
+(define (interaction-environment)
+  (fluid $interaction-environment))
+
+(define (set-interaction-environment! p)
+  (if (package? p)
+      (set-fluid! $interaction-environment p)
+      (call-error "invalid package" set-interaction-environment! p)))
+
+(define (with-interaction-environment p thunk)
+  (if (package? p)
+      (let-fluid $interaction-environment p thunk)
+      (call-error "invalid package" with-interaction-environment p)))
+
+
+; Scheme report environment.  Should be read-only; fix later.
+
+(define (scheme-report-environment n)
+  (if (= n *scheme-report-number*)
+      *scheme-report-environment*
+      (error "no such Scheme report environment")))
+
+(define *scheme-report-environment* #f)
+(define *null-environment* #f)
+(define *scheme-report-number* 0)
+
+(define (set-scheme-report-environment! repnum env)
+  (set! *scheme-report-number* repnum)
+  (set! *scheme-report-environment* env)
+  (set! *null-environment* env))		; A cheat.
+
+(define (null-environment n)
+  (if (= n *scheme-report-number*)
+      *null-environment*
+      (error "no such Scheme report environment")))
+
+; Make an infinite tower of packages for syntax.
+; structs should be a non-null list of structures that should be
+; opened at EVERY level of the tower.
+
+(define (make-reflective-tower eval structs id)
+  (let recur ((level 1))
+    (delay (cons eval
+		 (make-simple-package structs
+				      eval
+				      (recur (+ level 1))
+				      `(for-syntax ,level ,id))))))
+
+; (set-reflective-tower-maker! p (lambda (clauses id) ...))
+; where clauses is a list of DEFINE-STRUCTURE clauses
+
+(define set-reflective-tower-maker!
+  (let ((name (string->symbol ".make-reflective-tower.")))
+    (lambda (p proc)
+      (environment-define! p name proc))))
diff --git a/scheme/rts/eval.scm b/scheme/rts/eval.scm
new file mode 100644
index 0000000..990c48d
--- /dev/null
+++ b/scheme/rts/eval.scm
@@ -0,0 +1,58 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This file contains things that tie together the compiler and the
+; run-time system.
+
+; EVAL
+
+(define (eval form package)
+  (compile-and-run (list form) package #f #f))
+
+; LOAD-INTO - load file into package.
+
+(define (load-into filename package)
+  (really-load-into filename package #f))  
+
+; Evaluate forms as if they came from the given file.
+
+(define (eval-from-file forms package filename)
+  (if filename
+      ((fluid $note-file-package)
+        filename package))
+  (compile-and-run forms package filename #t))
+
+; LOAD
+
+(define (load filename . package-option)
+  (let ((package (if (null? package-option)
+		     (interaction-environment)
+		     (car package-option))))
+    (really-load-into filename package #t)))
+
+;----------------
+
+(define (really-load-into filename package note-undefined?)  
+  (force-output (current-output-port))	; just to make the output nice
+  (let ((forms (read-forms filename package)))
+    (newline (current-noise-port))	; READ-FORMS prints the filename
+    (compile-and-run forms
+		     package
+		     filename
+		     note-undefined?)))
+
+(define (compile-and-run forms package maybe-filename note-undefined?)
+  (let* ((env (if maybe-filename
+		  (bind-source-file-name maybe-filename
+					 (package->environment package))
+		  (package->environment package)))
+	 (template (compile-forms (map (lambda (form)
+					 (delay (expand-scanned-form form env)))
+				       (scan-forms forms env))
+				  maybe-filename)))
+    (link! template package note-undefined?)
+    (invoke-closure
+      (make-closure template
+		    (package-uid package)))))
+
+
diff --git a/scheme/rts/exception.scm b/scheme/rts/exception.scm
new file mode 100644
index 0000000..aebd4cd
--- /dev/null
+++ b/scheme/rts/exception.scm
@@ -0,0 +1,169 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+;;;; Raising and handling conditions
+
+; An exception is an unusual situation detected by the virtual machine.
+; A condition is a run-time system structure describing unusual situations,
+; including exceptions.
+
+; Usual exception handler vector.
+
+(define (define-exception-handler opcode proc)
+  (vector-set! exception-handlers opcode proc))
+
+(define (signal-exception opcode reason . args)
+  (really-signal-condition (make-exception opcode
+					   (if reason
+					       (enumerand->name reason exception)
+					       #f)
+					   args)))
+
+(define exception-handlers
+  (make-vector op-count signal-exception))
+
+; TRAP is the same as SIGNAL-CONDITION.
+
+(define-exception-handler (enum op trap)
+  (lambda (opcode reason arg)
+    (really-signal-condition arg)))
+
+; This is for generic arithmetic, mostly
+
+(define (extend-opcode! opcode make-handler)
+  (let* ((except (lambda args
+		   (apply signal-exception
+			  opcode
+			  #f   ; lost our reason
+			  args)))
+	 (handler (make-handler except)))
+    (define-exception-handler opcode
+      (lambda (opcode reason . args)
+	(apply handler args)))))
+
+; Raising and handling conditions.
+; (fluid $condition-handlers) is a list of handler procedures.
+; Each handler takes two arguments: the condition to be handled, and
+; a thunk that can be called if the handler decides to decline handling
+; the condition.  The continuation to a call to a handler is that
+; of the call to signal-condition.
+
+(define (really-signal-condition condition)
+  (let loop ((hs (fluid $condition-handlers)))
+    ((car hs) condition (lambda () (loop (cdr hs))))))
+
+(define (with-handler h thunk)
+  (let-fluid $condition-handlers
+      (cons h (fluid $condition-handlers))
+    thunk))
+
+(define $condition-handlers
+  (make-fluid #f))
+
+; CURRENT-ERROR-PORT and WRITE-STRING are passed in to avoid circular
+; module dependencies.
+
+(define (initialize-exceptions! current-error-port write-string thunk)
+  (call-with-current-continuation
+    (lambda (k)
+      (set-fluid! $condition-handlers
+		  (list (last-resort-condition-handler k
+						       current-error-port
+						       write-string)))
+      (set-exception-handlers! exception-handlers)
+      (thunk))))
+
+(define (last-resort-condition-handler halt current-error-port write-string)
+  (let ((interrupt/keyboard (enum interrupt keyboard))
+	(losing? #f))
+    (lambda (condition punt)
+      (cond ((error? condition)
+	     (primitive-catch
+	       (lambda (c)
+		 (if (not losing?)
+		     (begin (set! losing? #t)
+			    (report-utter-lossage condition
+						  c
+						  current-error-port
+						  write-string)))
+		 (halt 123))))
+	    ((and (interrupt? condition)
+		  (= (cadr condition) interrupt/keyboard))
+	     (halt 2))
+	    (else
+	     (unspecific))))))	;proceed
+
+; This will print a list of template id's, which you can look up in
+; initial.debug to get some idea of what was going on.
+
+(define (report-utter-lossage condition c current-error-port write-string)
+  (let ((out (current-error-port)))
+    (if out
+	(begin
+	  (cond ((exception? condition)
+		 (write-string (number->string (exception-opcode condition))
+			       out)
+		 (write-string " / " out))
+		((or (error? condition)
+		     (warning? condition))
+		 (write-string (car (condition-stuff condition)) out)
+		 (write-string " / " out)))
+	  (for-each (lambda (id+pc)
+		      (if (number? (car id+pc))
+			  (write-string (number->string
+					 (car id+pc))
+					out))
+		      (write-string " <- " out))
+		    (continuation-preview c))
+	  (write-char #\newline out)))))
+
+(define (continuation-preview c)
+  (if (continuation? c)
+      (cons (cons (template-info (continuation-template c))
+		  (continuation-pc c))
+	    (continuation-preview (continuation-parent c)))
+      '()))
+
+
+; ERROR is a compiler primitive, but if it weren't, it could be
+; defined as follows:
+
+;(define (error message . irritants)
+;  (signal-condition (make-condition 'error (cons message irritants))))
+
+; Run THUNK, returning either the value returned by THUNK or any error
+; that occurs.
+
+(define (ignore-errors thunk)
+  (call-with-current-continuation
+    (lambda (k)
+      (with-handler (lambda (c next)
+		      (if (error? c)
+			  (k c)
+			  (next)))
+	thunk))))
+
+; Downgrade errors to warnings while executing THUNK.  Returns #T if an
+; error occured.
+
+(define (report-errors-as-warnings thunk message . irritants)
+  (let ((condition (ignore-errors
+		    (lambda ()
+		      (thunk)
+		      #f))))
+    (if condition
+	(begin
+	  (apply warn message (append irritants (list condition)))
+	  #t)
+	#f)))
+
+; Define disclosers that are most important for error messages.
+
+(define-method &disclose ((obj :closure))
+  (list 'procedure (template-ref (closure-template obj) 1)))
+
+(define-method &disclose ((obj :location))
+  (list 'location (location-id obj)))
+
+; (put 'with-handler 'scheme-indent-hook 1)
diff --git a/scheme/rts/floatnum.scm b/scheme/rts/floatnum.scm
new file mode 100644
index 0000000..4ccc1e0
--- /dev/null
+++ b/scheme/rts/floatnum.scm
@@ -0,0 +1,284 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Inexact rational arithmetic using hacked-in floating point numbers.
+
+(define floatnum? double?)
+
+(define-enumeration flop
+  (+ - * / = <
+   fixnum->float
+   string->float
+   float->string
+   exp log sin cos tan asin acos atan sqrt
+   floor
+   integer?
+   float->fixnum
+   quotient
+   remainder))
+
+(define-syntax floperate
+  (syntax-rules ()
+    ((floperate ?which ?x)
+     (vm-extension (+ ?which 100) ?x))
+    ((floperate ?which ?x ?y)
+     (vm-extension (+ ?which 100) (cons ?x ?y)))
+    ((floperate ?which ?x ?y ?z)
+     (vm-extension (+ ?which 100) (vector ?x ?y ?z)))))
+
+(define (float&float->float op)
+  (lambda (a b)
+    (let ((res (make-double)))
+      (floperate op (x->float a) (x->float b) res)
+      res)))
+
+(define (float&float->boolean op)
+  (lambda (a b)
+    (floperate op (x->float a) (x->float b))))
+
+(define (float1 op)
+  (lambda (float)
+    (floperate op float)))
+
+(define (float->float op)
+  (lambda (a)
+    (let ((res (make-double)))
+      (floperate op (x->float a) res)
+      res)))
+
+(define (string->float string)
+  (let ((res (make-double)))
+    (floperate (enum flop string->float) string res)
+    res))
+
+; Call the OS to get a string and then add a `.' if necessary (so that
+; it will be inexact).
+
+(define (float->string float)
+  (let* ((res (make-string 40 #\space))
+	 (len (floperate (enum flop float->string)
+			 float
+			 res))
+	 (str (substring res 0 len)))
+    (let loop ((i 0))
+      (cond ((>= i (string-length str))
+	     (string-append str "."))
+	    ((char=? (string-ref str i) #\.)
+	     str)
+	    ((char=? (string-ref str i) #\e)
+	     (string-append (substring str 0 i)
+			    "."
+			    (substring str i (string-length str))))
+	    (else
+	     (loop (+ i 1)))))))
+
+(define (x->float x)
+  (cond ((double? x)
+	 x)
+	((integer? x)
+	 (exact-integer->float (if (exact? x)
+				   x
+				   (inexact->exact x))))
+	((rational? x)
+	 ;; This loses when num or den overflows flonum range
+	 ;; but x doesn't.
+	 (float/ (numerator x) (denominator x)))
+	(else
+	 (error "cannot coerce to a float" x))))
+
+; Conversion to/from exact integer
+
+(define (exact-integer->float k)
+  (or (fixnum->float k)
+      (float+ (float* (fixnum->float definitely-a-fixnum)
+		      (quotient k definitely-a-fixnum))
+	      (fixnum->float (remainder k definitely-a-fixnum)))))
+
+(define (fixnum->float k)    ;Returns #f is k is a bignum
+  (let ((res (make-double)))
+    (if (floperate (enum flop fixnum->float) k res)
+	res
+	#f)))
+
+(define (float->exact-integer x)
+  (or (float->fixnum x)
+      (let ((d (fixnum->float definitely-a-fixnum)))
+	(+ (* definitely-a-fixnum
+	      (float->exact-integer (float-quotient x d)))
+	   (float->fixnum (loophole :double		; outsmarted ourselves
+				    (float-remainder x d)))))))
+
+(define definitely-a-fixnum (expt 2 23))    ;Be conservative
+
+(define integral-floatnum? (float1 (enum flop integer?)))
+(define float->fixnum      (float1 (enum flop float->fixnum)))
+
+(define float+ (float&float->float (enum flop +)))
+(define float- (float&float->float (enum flop -)))
+(define float* (float&float->float (enum flop *)))
+(define float/ (float&float->float (enum flop /)))
+(define float-quotient (float&float->float (enum flop quotient)))
+(define float-remainder (float&float->float (enum flop remainder)))
+(define float-atan (float&float->float (enum flop atan)))
+
+(define float= (float&float->boolean (enum flop =)))
+(define float< (float&float->boolean (enum flop <)))
+
+(define float-exp (float->float (enum flop exp)))
+(define float-log (float->float (enum flop log)))
+(define float-sin (float->float (enum flop sin)))
+(define float-cos (float->float (enum flop cos)))
+(define float-tan (float->float (enum flop tan)))
+(define float-asin (float->float (enum flop asin)))
+(define float-acos (float->float (enum flop acos)))
+(define float-sqrt (float->float (enum flop sqrt)))
+(define float-floor (float->float (enum flop floor)))
+
+; This lets you do ,open floatnum to get faster invocation
+(begin 
+  (define exp float-exp)
+  (define log float-log)
+  (define sin float-sin)
+  (define cos float-cos)
+  (define tan float-tan)
+  (define asin float-asin)
+  (define acos float-acos)
+  (define atan float-atan)
+  (define sqrt float-sqrt))
+
+(define (float-fraction-length x)
+  (let ((two (exact-integer->float 2)))
+    (do ((x x (float* x two))
+	 (i 0 (+ i 1)))
+	((integral-floatnum? x) i)
+      (if (> i 1000) (error "I'm bored." x)))))
+
+(define (float-denominator x)
+  (expt (exact-integer->float 2) (float-fraction-length x)))
+
+(define (float-numerator x)
+  (float* x (float-denominator x)))
+
+(define (float->exact x)
+  (if (integral-floatnum? x)
+      (float->exact-integer x)		;+++
+      (let ((lose (lambda ()
+		    (call-error "no exact representation"
+				inexact->exact x)))
+	    (q (expt 2 (float-fraction-length x))))
+	(if (exact? q)
+	    (let ((e (/ (float->exact-integer
+			     (float* x (exact-integer->float q)))
+			q)))
+	      (if (exact? e)
+		  e
+		  (lose)))
+	    (lose)))))
+
+
+; Methods on floatnums
+
+(define-method &integer? ((x :double))
+  (integral-floatnum? x))
+
+(define-method &rational? ((n :double)) #t)
+
+(define-method &exact? ((x :double)) #f)
+
+(define-method &inexact->exact ((x :double))
+  (float->exact x))
+
+(define-method &exact->inexact ((x :rational))
+  (x->float x))		;Should do this only if the number is within range.
+
+(define-method &floor ((x :double)) (float-floor x))
+
+; beware infinite regress
+(define-method &numerator ((x :double)) (float-numerator x))
+(define-method &denominator ((x :double)) (float-denominator x))
+
+(define (define-floatnum-method mtable proc)
+  (define-method mtable ((m :rational) (n :rational)) (proc m n)))
+
+(define-floatnum-method &+ float+)
+(define-floatnum-method &- float-)
+(define-floatnum-method &* float*)
+(define-floatnum-method &/ float/)
+(define-floatnum-method &quotient float-quotient)
+(define-floatnum-method &remainder float-remainder)
+(define-floatnum-method &= float=)
+(define-floatnum-method &< float<)
+
+(define-method &numerator ((x :rational)) (float-numerator x))
+(define-method &denominator ((x :rational)) (float-denominator x))
+
+(define-method &exp ((x :rational)) (float-exp x))
+(define-method &log ((x :rational)) (float-log x))
+(define-method &sqrt ((x :rational)) (float-sqrt x))
+(define-method &sin ((x :rational)) (float-sin x))
+(define-method &cos ((x :rational)) (float-cos x))
+(define-method &tan ((x :rational)) (float-tan x))
+(define-method &acos ((x :rational)) (float-acos x))
+
+(define-floatnum-method &atan float-atan)
+
+(define-method &number->string ((n :double) radix)
+  (if (= radix 10)
+      (float->string n)
+      (next-method)))
+
+; Recognizing a floating point number.  This doesn't know about `#'.
+
+(define (float-string? s)
+  (let ((len (string-length s)))
+    (define (start)
+      (and (< 1 len)
+	   (let ((first (string-ref s 0))
+		 (second (string-ref s 1)))
+	     (if (char-numeric? first)
+		 (digits 1 #f #f)
+		 (case first
+		   ((#\+ #\-)
+		    (and (char-numeric? second)
+			 (digits 2 #f #f)))
+		   ((#\.)
+		    (and (char-numeric? second)
+			 (digits 2 #t #f)))
+		   (else #f))))))
+
+    ; Read digits until the end or an `e' or a `.'.  E-OR-DOT? is true if
+    ; we have seen either, E? is true if we've seen an `e'.
+    (define (digits i e-or-dot? e?)
+      (if (= i len)
+	  e-or-dot?
+	  (let ((next (string-ref s i)))
+	    (if (char-numeric? next)
+		(digits (+ i 1) e-or-dot? e?)
+		(case next
+		  ((#\e #\E)
+		   (and (not e?)
+			(exponent (+ i 1) #f)))
+		  ((#\.)
+		   (and (not e-or-dot?)
+			(digits (+ i 1) #t #f)))
+		  (else #f))))))
+
+    ; Read in an exponent.  If SIGN? is true then we have already got the sign.
+    (define (exponent i sign?)
+      (and (< i len)
+	   (let ((next (string-ref s i)))
+	     (if (char-numeric? next)
+		 (digits (+ i 1) #t #t)
+		 (case next
+		   ((#\+ #\-)
+		    (and (not sign?)
+			 (exponent (+ i 1) #t)))
+		   (else #f))))))
+    (start)))
+
+(define-simple-type :float-string (:string) float-string?)
+
+(define-method &really-string->number ((s :float-string) radix exact?)
+  (if (and (= radix 10)
+	   (not exact?))
+      (string->float s)
+      (next-method)))
diff --git a/scheme/rts/fluid.scm b/scheme/rts/fluid.scm
new file mode 100644
index 0000000..a2337b3
--- /dev/null
+++ b/scheme/rts/fluid.scm
@@ -0,0 +1,94 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; This is file fluid.scm.
+
+; Fluid (dynamic) variables.
+
+; Fluid variables are implemented using deep binding.  This allows
+; each thread in a multiprocessor system to have its own fluid
+; environment, and allows for fast thread switching in a multitasking
+; one.
+
+; CURRENT-THREAD and SET-CURRENT-THREAD! access a special virtual
+; machine register.  On a multiprocessor, each processor would have
+; its own current-thread register.  The run-time system stores the
+; current thread in this register.
+
+; Here we define a particular thread record, but a different one is
+; defined by the (uniprocessor) threads package.  The current thread
+; may actually be any kind of record as long as its first component
+; can be used by the fluid variable implementation to maintain the
+; deep-binding dynamic environment and its second component can be
+; used by DYNAMIC-WIND.  This is kind of gross but it is motivated by
+; efficiency concerns.
+
+(define-record-type thread :thread
+  (make-thread dynamic-env dynamic-point)
+  (dynamic-env thread-dynamic-env)
+  (dynamic-point thread-dynamic-point))
+
+(define (get-dynamic-env)
+  (record-ref (current-thread) 1))
+
+(define (set-dynamic-env! env)
+  (record-set! (current-thread) 1 env))
+
+; The dynamic-wind point used to be just an ordinary fluid variable, which
+; doesn't work well with threads.
+
+(define (get-dynamic-point)
+  (record-ref (current-thread) 2))
+
+(define (set-dynamic-point! point)
+  (record-set! (current-thread) 2 point))
+
+(define (initialize-dynamic-state!)
+  (set-current-thread! (make-thread (empty-dynamic-env) #f)))
+
+;----------------
+; Dynamic environment
+; A dynamic environment is an alist where the cars are fluid records.
+
+(define (with-dynamic-env env thunk)
+  (let ((saved-env (get-dynamic-env)))
+    (set-dynamic-env! env)
+    (set! env #f)			;For GC and debugger
+    (call-with-values
+	;; thunk
+	(let ((x thunk)) (set! thunk #f) x) ;For GC
+      (lambda results
+	(set-dynamic-env! saved-env)
+	(apply values results)))))
+
+(define (empty-dynamic-env) '())
+
+; Each fluid has a top-level value that is used when the fluid is unbound
+; in the current dynamic environment.
+
+(define-record-type fluid :fluid
+  (make-fluid top)
+  (top fluid-top-level-value set-fluid-top-level-value!))
+
+(define (fluid f)
+  (let ((probe (assq f (get-dynamic-env))))
+    (if probe (cdr probe) (fluid-top-level-value f))))
+
+(define (set-fluid! f val)
+  (let ((probe (assq f (get-dynamic-env))))
+    (if probe (set-cdr! probe val) (set-fluid-top-level-value! f val))))
+
+(define (let-fluid f val thunk)
+  (with-dynamic-env (cons (cons f val) (get-dynamic-env)) thunk))
+
+(define (let-fluids . args)
+  (let loop ((args args)
+	     (env (get-dynamic-env)))
+    (if (null? (cdr args))
+	(with-dynamic-env env (car args))
+	(loop (cddr args)
+	      (cons (cons (car args) (cadr args)) env)))))
+
+; Initialize
+
+(initialize-dynamic-state!)
+
diff --git a/scheme/rts/init.scm b/scheme/rts/init.scm
new file mode 100644
index 0000000..501efb4
--- /dev/null
+++ b/scheme/rts/init.scm
@@ -0,0 +1,39 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; System entry and exit
+
+; Entry point from OS executive.  Procedures returned by USUAL-RESUMER
+; are suitable for use as the second argument to WRITE-IMAGE.
+;
+; The placement of INITIALIZE-RECORDS! is questionable.  Important parts
+; of the system are not in place when it is run.
+
+(define (usual-resumer entry-point)
+  (lambda (resume-arg in out error records)
+    (initialize-rts in out error
+     (lambda ()
+       (initialize-records! records)
+       (entry-point (vector->list resume-arg))))))
+       
+(define (initialize-rts in out error thunk)
+  (initialize-session-data!)
+  (initialize-dynamic-state!)
+  (initialize-output-port-list!)
+  (initialize-exceptions! current-error-port write-string
+    (lambda ()
+      (initialize-interrupts!
+       spawn-on-root
+       (lambda ()
+	 (initialize-i/o (input-channel->port in)
+			 (output-channel->port out)
+	                 (output-channel->port error 0)  ; zero-length buffer
+	     (lambda ()
+	       (with-threads
+		(lambda ()
+		  (root-scheduler thunk
+				  200           ; thread quantum, in msec
+				  300)))))))))) ; port-flushing quantum
+
+; Add the full/empty buffer handlers.
+
+(initialize-i/o-handlers! define-exception-handler signal-exception)
diff --git a/scheme/rts/innum.scm b/scheme/rts/innum.scm
new file mode 100644
index 0000000..c63dd1a
--- /dev/null
+++ b/scheme/rts/innum.scm
@@ -0,0 +1,108 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Inexact numbers as mere shells surrounding exact numbers.
+
+(define-extended-number-type :innum (:inexact)
+  (make-innum exact)
+  innum?
+  (exact innum-exact))
+
+(define-method &exact?  ((n :innum)) #f)
+
+(define-method &complex?  ((n :innum)) (complex?  (innum-exact n)))
+(define-method &real?     ((n :innum)) (real?	  (innum-exact n)))
+(define-method &rational? ((n :innum)) (rational? (innum-exact n)))
+(define-method &integer?  ((n :innum)) (integer?  (innum-exact n)))
+
+(define-method &exact->inexact (n)
+  (if (innum? n)
+      (next-method)
+      (make-innum n)))
+
+(define-method &inexact->exact ((n :innum)) (innum-exact n))
+
+(define (inexactify n)
+  (if (exact? n)
+      (exact->inexact n)
+      n))
+
+(define (define-innum-method mtable proc)
+  (define-method mtable ((m :innum) (n :number))
+    (inexactify (proc (innum-exact m) n)))
+  (define-method mtable ((m :number) (n :innum))
+    (inexactify (proc m (innum-exact n)))))
+
+(define-innum-method &+ +)
+(define-innum-method &- -)
+(define-innum-method &* *)
+(define-innum-method &/ /)
+(define-innum-method &quotient quotient)
+(define-innum-method &remainder remainder)
+
+(define (define-innum-comparison mtable proc)
+  (define-method mtable ((m :innum) (n :number))
+    (proc (innum-exact m) n))
+  (define-method mtable ((m :number) (n :innum))
+    (proc m (innum-exact n))))
+
+(define-innum-comparison &= =)
+(define-innum-comparison &< <)
+
+(define-method &numerator   ((n :innum))
+  (inexactify (numerator (innum-exact n))))
+
+(define-method &denominator ((n :innum))
+  (inexactify (denominator (innum-exact n))))
+
+(define-method &floor ((n :innum))
+  (inexactify (floor (innum-exact n))))
+
+(define-method &number->string ((i :innum) radix)
+  (let ((n (innum-exact i)))
+    (cond ((integer? n)
+	   (string-append (number->string n radix) "."))
+	  ((rational? n)
+	   (let ((q (denominator n)))
+	     (if (= radix 10)
+		 (let ((foo (decimable? q)))
+		   (if foo
+		       (decimal-representation (numerator n) q foo)
+		       (string-append "#i" (number->string n radix))))
+		 (string-append "#i" (number->string n radix)))))
+	  (else
+	   (string-append "#i" (number->string n radix))))))
+
+; The Scheme report obligates us to print inexact rationals using
+; decimal points whenever this can be done without losing precision.
+
+(define (decimal-representation p q foo)
+  (let ((kludge (number->string (* (car foo) (abs (remainder p q)))
+				10)))
+    (string-append (if (< p 0) "-" "")
+		   (number->string (quotient (abs p) q) 10)
+		   "."
+		   (string-append (do ((i (- (cdr foo) (string-length kludge))
+					  (- i 1))
+				       (l '() (cons #\0 l)))
+				      ((<= i 0) (list->string l)))
+				  kludge))))
+
+(define (ratio-string p q radix)
+  (string-append (number->string p radix)
+		 "/"
+		 (number->string q radix)))
+
+; (decimable? n) => non-#f iff n is a product of 2's and 5's.
+; The value returned is (k . i) such that 10^i divides n * k.
+
+(define (decimable? n)
+  (let loop ((n n) (d 1) (i 0))
+    (if (= n 1)
+	(cons d i)
+	(let ((q (quotient n 10))
+	      (r (remainder n 10)))
+	  (cond ((= r 0) (loop q d (+ i 1)))
+		((= r 5) (loop (quotient n 5) (* d 2) (+ i 1)))
+		((even? r) (loop (quotient n 2) (* d 5) (+ i 1)))
+		(else #f))))))
diff --git a/scheme/rts/interrupt.scm b/scheme/rts/interrupt.scm
new file mode 100644
index 0000000..bf53bd7
--- /dev/null
+++ b/scheme/rts/interrupt.scm
@@ -0,0 +1,118 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Interrupts
+
+; Create and install a vector of interrupt handlers.  We want this to happen
+; as early as possible.  All but the post-gc and keyboard interrupts raise an
+; exception by default.  We exit when a keyboard interrupt occurs. The default
+; post-gc handler is defined below.
+
+(define (initialize-interrupts! spawn-on-root thunk)
+  (primitive-cwcc
+    (lambda (exit)
+      (let ((handlers (make-vector interrupt-count 0)))
+	(do ((i 0 (+ i 1)))
+	    ((= i interrupt-count))
+	  (vector-set! handlers
+		       i
+		       (lambda stuff
+			 (apply signal (cons 'interrupt (cons i stuff))))))
+	(vector-set! handlers
+		     (enum interrupt post-gc)
+		     (post-gc-handler spawn-on-root))
+	(vector-set! handlers
+		     (enum interrupt keyboard)
+		     (lambda args
+		       (with-continuation exit (lambda () -1))))
+	(set-interrupt-handlers! handlers)
+	(session-data-set! interrupt-handlers handlers))
+      (set-enabled-interrupts! all-interrupts)
+      (thunk))))
+  
+(define interrupt-handlers (make-session-data-slot! 0))
+
+; Set an interrupt handler.
+
+(define (set-interrupt-handler! interrupt handler)
+  (vector-set! (session-data-ref interrupt-handlers)
+	       interrupt
+	       handler))
+      
+(define no-interrupts 0)
+
+(define all-interrupts
+  (- (arithmetic-shift 1 interrupt-count) 1))
+
+(define (with-interrupts-inhibited thunk)
+  (with-interrupts no-interrupts thunk))
+
+(define (with-interrupts-allowed thunk)
+  (with-interrupts all-interrupts thunk))
+
+(define (disable-interrupts!)
+  (set-enabled-interrupts! no-interrupts))
+
+(define (enable-interrupts!) 
+  (set-enabled-interrupts! all-interrupts))
+
+(define (with-interrupts interrupts thunk)
+  ;; I might consider using dynamic-wind here, but (a) I'm worried
+  ;; about the speed of thread switching (which uses this) and (b)
+  ;; it's a pretty bad idea to throw in or out of one of these anyhow.
+  (let ((ei (set-enabled-interrupts! interrupts)))
+    (call-with-values thunk
+      (lambda results
+	(set-enabled-interrupts! ei)
+	(apply values results)))))
+
+(define (enabled-interrupts)		;For debugging
+  (let ((e (set-enabled-interrupts! 0)))
+    (set-enabled-interrupts! e)
+    e))
+
+;----------------
+; Post-GC interrupts
+
+(define *post-gc-procedures* '())
+
+(define (call-after-gc! thunk)
+  (if (not (memq thunk *post-gc-procedures*))
+      (set! *post-gc-procedures* (cons thunk *post-gc-procedures*))))
+
+(define (post-gc-handler spawn-on-root)
+  (lambda (finalizer-list enabled-interrupts)
+    (let ((space (memory-status (enum memory-status-option available) 0)))
+      (if (> (session-data-ref required-post-gc-space)
+	     space)
+	  (spawn-on-root
+	   (lambda ()
+	     ((session-data-ref space-shortage-handler)
+	      (session-data-ref required-post-gc-space)
+	      space)))))
+    (spawn-on-root
+     (lambda ()
+       (for-each (lambda (p)
+		   ((cdr p) (car p)))
+		 finalizer-list)
+       (for-each (lambda (thunk)
+		   (thunk))
+		 *post-gc-procedures*))
+     'post-gc-handler)
+    (set-enabled-interrupts! enabled-interrupts)))
+
+; Notifying someone if an insufficient amount of memory is reclaimed by
+; a garbage collection.  The amount defaults to 10% of the heap.
+
+(define required-post-gc-space (make-session-data-slot! 0))
+
+(define space-shortage-handler
+  (make-session-data-slot! (lambda (required space) #f)))
+
+(define (call-before-heap-overflow! handler . maybe-required-space)
+  (session-data-set! required-post-gc-space
+		     (if (null? maybe-required-space)
+			 (quotient (memory-status (enum memory-status-option heap-size) 0)
+				   10)
+			 (car maybe-required-space)))
+  (session-data-set! space-shortage-handler handler))
diff --git a/scheme/rts/jar-defrecord.scm b/scheme/rts/jar-defrecord.scm
new file mode 100644
index 0000000..ddaa981
--- /dev/null
+++ b/scheme/rts/jar-defrecord.scm
@@ -0,0 +1,105 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This knows about the implementation of records and creates the various
+; accessors, mutators, etc. directly instead of calling the procedures
+; from the record structure.  This is done to allow the optional auto-inlining
+; optimizer to inline the accessors, mutators, etc.
+
+; LOOPHOLE is used to get a little compile-time type checking (in addition to
+; the usual complete run-time checking).
+
+(define-syntax define-record-type
+  (syntax-rules ()
+    ((define-record-type ?id ?type
+       (?constructor ?arg ...)
+       (?field . ?field-stuff)
+       ...)
+     (begin (define ?type (make-record-type '?id '(?field ...)))
+	    (define-constructor ?constructor ?type
+	      ((?arg :value) ...)
+	      (?field ...))
+	    (define-accessors ?type (?field . ?field-stuff) ...)))
+    ((define-record-type ?id ?type
+       (?constructor ?arg ...)
+       ?pred
+       ?more ...)
+     (begin (define-record-type ?id ?type
+	      (?constructor ?arg ...)
+	      ?more ...)
+	    (define ?pred
+	      (lambda (x)
+		(and (record? x)
+		     (eq? ?type (record-ref x 0)))))))))
+
+; (define-constructor <id> <type> ((<arg> <arg-type>)*) (<field-name>*))
+;
+; Checks to see that there is an <arg> corresponding to every <field-name>.
+
+(define-syntax define-constructor
+  (lambda (e r c)
+    (let ((%record (r 'record))
+	  (%begin (r 'begin))
+	  (%lambda (r 'lambda))
+	  (%loophole (r 'loophole))
+	  (%proc (r 'proc))
+	  (%unspecific (r 'unspecific))
+	  (name (cadr e))
+	  (type (caddr e))
+	  (args (map car (cadddr e)))
+	  (arg-types (map cadr (cadddr e)))
+	  (fields (caddr (cddr e))))
+      (define (mem? name list)
+	(cond ((null? list)        #f)
+	      ((c name (car list)) #t)
+	      (else
+	       (mem? name (cdr list)))))
+      (define (every? pred list)
+	(cond ((null? list)        #t)
+	      ((pred (car list))
+	       (every? pred (cdr list)))
+	      (else #f)))
+      (if (every? (lambda (arg)
+		    (mem? arg fields))
+		  args)
+	  `(define ,name
+	     (,%loophole (,%proc ,arg-types ,type)
+			 (,%lambda ,args
+			     (,%record ,type . ,(map (lambda (field)
+						       (if (mem? field args)
+							   field
+							   (list %unspecific)))
+						     fields)))))
+	  e)))
+  (record begin lambda loophole proc unspecific))
+
+(define-syntax define-accessors
+  (lambda (e r c)
+    (let ((%define-accessor (r 'define-accessor))
+	  (%begin (r 'begin))
+	  (type (cadr e))
+	  (field-specs (cddr e)))
+      (do ((i 1 (+ i 1))
+	   (field-specs field-specs (cdr field-specs))
+	   (ds '()
+	       (cons `(,%define-accessor ,type ,i ,@(cdar field-specs))
+		     ds)))
+	  ((null? field-specs)
+	   `(,%begin ,@ds)))))
+  (define-accessor begin))
+
+(define-syntax define-accessor
+  (syntax-rules ()
+    ((define-accessor ?type ?index ?accessor)
+     (define ?accessor
+       (loophole (proc (?type) :value)
+		 (lambda (r)
+		   (checked-record-ref (loophole :record r) ?type ?index)))))
+    ((define-accessor ?type ?index ?accessor ?modifier)
+     (begin (define-accessor ?type ?index ?accessor)
+	    (define ?modifier
+	      (loophole (proc (?type :value) :unspecific)
+			(lambda (r new)
+			  (checked-record-set! (loophole :record r) ?type ?index new))))))
+    ((define-accessor ?type ?index)
+     (begin))))
diff --git a/scheme/rts/lize.scm b/scheme/rts/lize.scm
new file mode 100644
index 0000000..e9e8d8b
--- /dev/null
+++ b/scheme/rts/lize.scm
@@ -0,0 +1,35 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Simplest rational within an interval.  Copied from IEEE P1178/D4 nimpl.tex.
+
+(define (rationalize x e)
+  (let ((e (abs e)))
+    (simplest-rational (- x e) (+ x e))))
+
+(define (simplest-rational x y)
+  (define (simplest-rational-internal x y)
+    ;; assumes 0 < X < Y
+    (let ((fx (floor x))
+          (fy (floor y)))
+      (cond ((not (< fx x))
+             fx)
+            ((= fx fy)
+             (+ fx
+		(/ 1 (simplest-rational-internal
+		      (/ 1 (- y fy))
+		      (/ 1 (- x fx))))))
+            (else
+             (+ 1 fx)))))
+  ;; Do some juggling to satisfy preconditions of simplest-rational-internal.
+  (cond ((not (< x y))
+         (if (rational? x) x (error "(rationalize <irrational> 0)" x)))
+        ((positive? x)
+         (simplest-rational-internal x y))
+        ((negative? y)
+         (- 0 (simplest-rational-internal (- 0 y) (- 0 x))))
+        (else
+         (if (and (exact? x) (exact? y))
+             0
+             (exact->inexact 0)))))
+
diff --git a/scheme/rts/lock.scm b/scheme/rts/lock.scm
new file mode 100644
index 0000000..aa6f3a6
--- /dev/null
+++ b/scheme/rts/lock.scm
@@ -0,0 +1,56 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+; Locks (= semaphores)
+
+; Each lock has:
+;   The owning thread's uid, or #f if not locked.  The uid can be used
+;     to aid debugging without introducing the overhead of a weak pointer
+;     to the actual thread (a non-weak pointer would introduce an unfortunate
+;     circularity involving the locks and finalizers of ports).
+;   A queue of waiting threads
+
+(define-record-type lock :lock
+  (really-make-lock owner-uid queue uid)
+  lock?
+  (owner-uid lock-owner-uid set-lock-owner-uid!)
+  (queue lock-queue)
+  (uid lock-uid))     ; for debugging
+
+(define *lock-uid* 0)
+
+(define (make-lock)
+  (let ((uid *lock-uid*))
+    (set! *lock-uid* (+ uid 1))
+    (really-make-lock #f (make-thread-queue) uid)))
+
+(define (obtain-lock lock)
+  (with-interrupts-inhibited
+   (lambda ()
+     (if (lock-owner-uid lock)
+	 (begin
+	   (enqueue-thread! (lock-queue lock) (current-thread))
+	   (block))
+	 (set-lock-owner-uid! lock (thread-uid (current-thread)))))))
+
+(define (maybe-obtain-lock lock)
+  (with-interrupts-inhibited
+   (lambda ()
+     (if (lock-owner-uid lock)
+	 #f
+	 (begin
+	   (set-lock-owner-uid! lock (thread-uid (current-thread)))
+	   #t)))))
+
+; Returns #t if the lock has no new owner.
+
+(define (release-lock lock)
+  (with-interrupts-inhibited
+   (lambda ()
+     (let ((queue (lock-queue lock)))
+       (if (thread-queue-empty? queue)
+	   (begin
+	     (set-lock-owner-uid! lock #f)
+	     #t)
+	   (let ((next (dequeue-thread! queue)))
+	     (set-lock-owner-uid! lock (thread-uid next))
+	     (make-ready next)
+	     #f))))))
diff --git a/scheme/rts/low.scm b/scheme/rts/low.scm
new file mode 100644
index 0000000..a640c11
--- /dev/null
+++ b/scheme/rts/low.scm
@@ -0,0 +1,193 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Low-level things that rely on the fact that we're running under the
+; Scheme 48 VM.
+
+; Needs LET macro.
+
+
+; Characters are not represented in ASCII.  Using a different encoding
+; helps to catch portability problems.
+
+(define (char->integer c) (+ (char->ascii c) 1000))
+(define (integer->char n) (ascii->char (- n 1000)))
+
+(define ascii-limit 256)		;for reader
+(define ascii-whitespaces '(32 10 9 12 13)) ;space linefeed tab page return
+
+
+; Procedures and closures are two different abstractions.  Procedures
+; are created by LAMBDA and invoked with procedure call; those are
+; their only defined operations.  Closures are made with MAKE-CLOSURE,
+; accessed using CLOSURE-TEMPLATE and CLOSURE-ENV, and invoked by
+; INVOKE-CLOSURE, which starts the virtual machine going.
+
+; In a running Scheme 48 system, the two happen to be implemented
+; using the same data type.  The following is the only part of the
+; system that should know this fact.
+
+(define procedure? closure?)
+
+(define (invoke-closure closure . args)
+  (apply (loophole :procedure closure)
+	 args))
+
+
+; Similarly, there are escapes and there are VM continuations.
+; Escapes are obtained with PRIMITIVE-CWCC and invoked with
+; WITH-CONTINUATION.  VM continuations are obtained with
+; PRIMITIVE-CATCH and inspected using CONTINUATION-REF and friends.
+; (This is not such a hot naming strategy; it would perhaps be better
+; to use the terms "continuation" and "frame".)
+
+; In a running Scheme 48 system, the two happen to be implemented
+; using the same data type.  The following is the only part of the
+; system that should know this fact.
+
+(define (primitive-cwcc p)
+  (primitive-catch (lambda (cont)
+		     (p (loophole :escape cont))))) ;?
+
+; (define (invoke-continuation cont thunk)
+;   (with-continuation (loophole :escape cont) thunk))
+
+
+; These two procedures are part of the location abstraction.
+
+(define (make-undefined-location id)
+  (let ((loc (make-location id #f)))
+    (set-location-defined?! loc #f)
+    loc))
+
+(define (location-assigned? loc)
+  (and (location-defined? loc)
+       (if (eq? (contents loc)
+		(unassigned))
+	   #f
+	   #t)))
+
+; Used by the inspector.
+
+(define (vector-unassigned? v i)
+  (eq? (vector-ref v i) (unassigned)))
+
+
+; STRING-COPY is here because it's needed by STRING->SYMBOL.
+
+(define (string-copy s)
+  (let ((z (string-length s)))
+    (let ((copy (make-string z #\space)))
+      (copy-bytes! s 0 copy 0 z)
+      copy)))
+
+; The symbol table
+
+(define (string->symbol string)
+  (intern (if (immutable? string)
+	      string			;+++
+	      (make-immutable! (string-copy string)))))
+
+; The following magic bitmasks are derived from PORT-STATUS-OPTIONS in arch.scm.
+
+(define (input-port? port)
+  (and (port? port)
+       (= 1 (bitwise-and 1 (port-status port)))))
+
+(define (output-port? port)
+  (and (port? port)
+       (= 2 (bitwise-and 2 (port-status port)))))
+
+
+; code-vectors == byte-vectors
+; These are functions so that they will be inlined.
+
+(define (make-code-vector length init) (make-byte-vector length init))
+(define (code-vector? x) (byte-vector? x))
+(define (code-vector-length bv) (byte-vector-length bv))
+(define (code-vector-ref bv i) (byte-vector-ref bv i))
+(define (code-vector-set! bv i x) (byte-vector-set! bv i x))
+
+; Block reads and writes in terms of partial reads and writes.
+
+; CHANNEL-READ returns the number of characters read or the EOF object.
+; BUFFER is either a string or byte vector and START is the index at which
+; to place the first character read.  NEEDED is one of
+;  <integer> : the call returns when this many characters has been read or
+;     an EOF is reached.
+;  'IMMEDIATE : the call reads as many characters as are available and
+;     returns immediately.
+;  'ANY : the call returns as soon as at least one character has been read
+;     or an EOF is reached.
+
+(define (channel-read buffer start needed channel)
+  (call-with-values
+   (lambda ()
+     (cond ((eq? needed 'immediate)
+	    (values #f 0 (- (buffer-length buffer) start)))
+	   ((eq? needed 'any)
+	    (values #t 1 (- (buffer-length buffer) start)))
+	   (else
+	    (values #t needed needed))))
+   (lambda (keep-trying? need max-chars)
+     (let loop ((have 0))
+       (let ((got (channel-maybe-read buffer
+				      (+ start have)
+				      (- max-chars have)
+				      keep-trying?
+				      channel)))
+	 (if (eof-object? got)
+	     (if (= have 0)
+		 (eof-object)
+		 have)
+	     (let ((have (+ have got)))
+	       (if (and keep-trying? (< have need))
+		   (loop have)
+		   have))))))))
+
+(define (buffer-length buffer)	   
+  (if (byte-vector? buffer)
+      (byte-vector-length buffer)
+      (string-length buffer)))
+
+; Write COUNT characters from BUFFER, which is either a string or a byte-vector,
+; to CHANNEL, beginning with the character at START.  No meaningful value is
+; returned.
+
+(define (channel-write buffer start count channel)
+  (let loop ((sent 0))
+    (if (< sent count)
+	(loop (+ sent
+		 (channel-maybe-write buffer
+				      (+ start sent)
+				      (- count sent)
+				      channel))))))
+
+; Shared bindings - six procedures from two primitives.  The lookup and
+; undefine primitives take a flag which is true for imports and false for
+; exports.
+
+(define (lookup-imported-binding name)
+  (lookup-shared-binding name #t))
+
+(define (lookup-exported-binding name)
+  (lookup-shared-binding name #f))
+
+(define (define-imported-binding name value)
+  (shared-binding-set! (lookup-shared-binding name #t)
+		       value))
+  
+(define (define-exported-binding name value)
+  (shared-binding-set! (lookup-shared-binding name #f)
+		       value))
+
+(define (undefine-imported-binding name)
+  (undefine-shared-binding name #t))
+
+(define (undefine-exported-binding name)
+  (undefine-shared-binding name #f))
+
+; Writing debugging messages.
+
+(define (debug-message . stuff)
+  (message stuff))
diff --git a/scheme/rts/method.scm b/scheme/rts/method.scm
new file mode 100644
index 0000000..de4d91e
--- /dev/null
+++ b/scheme/rts/method.scm
@@ -0,0 +1,515 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Generic procedure package
+
+; This is written in fairly portable Scheme.  It needs:
+;   Scheme 48 low-level macros (explicit renaming), in one small place.
+;   (CALL-ERROR message proc arg ...)  - signal an error.
+;   Record package and DEFINE-RECORD-TYPES macro.
+;   An object :RECORD-TYPE which is the record type descriptor for
+;     record type descriptors (records are assumed to be records).
+;     This wouldn't be difficult to change.
+;   A RECORD? predicate (not essential - only for defining a DISCLOSE
+;     method for records).
+
+; --------------------
+; Simple types.
+; More specific types have higher priorities.  The priorities are used
+; to establish the ordinary in which type predicates are called.
+
+(define-record-type simple-type :simple-type
+  (really-make-simple-type supers predicate priority id)
+  simple-type?
+  (supers simple-type-superiors)
+  (predicate simple-type-predicate)
+  (priority simple-type-priority)
+  (id simple-type-id)
+  (more))    ;if needed later
+
+(define-record-discloser :simple-type
+  (lambda (c) `(simple-type ,(simple-type-id c))))
+
+(define (make-simple-type supers predicate id)
+  (make-immutable!
+   (really-make-simple-type supers
+			    predicate
+			    (compute-priority supers)
+			    id)))
+
+(define (compute-priority supers)
+  (if (null? supers)
+      0
+      (+ (apply max (map %type-priority supers))
+	 *increment*)))
+
+(define *increment* 10)
+
+
+; These two procedures will become generic later, but must exist early
+; in order to be able to bootstrap the method definition mechanism.
+
+(define (%type-priority type)
+  (cond ((simple-type? type)
+	 (simple-type-priority type))
+	((record-type? type)
+	 (record-type-priority type))
+	(else (type-priority type))))	;generic
+
+(define (%type-predicate type)
+  (cond ((simple-type? type)
+	 (simple-type-predicate type))
+	((record-type? type)
+	 (record-predicate type))
+	(else (type-predicate type))))  ;generic
+
+(define (%same-type? t1 t2)
+  (or (eq? t1 t2)
+      (if (simple-type? t1)
+	  #f
+	  (if (record-type? t1)
+	      #f
+	      (same-type? t1 t2)))))
+	  
+
+(define-syntax define-simple-type
+  (syntax-rules ()
+    ((define-simple-type ?name (?super ...) ?pred)
+     (define ?name (make-simple-type (list ?super ...) ?pred '?name)))))
+
+; --------------------
+; Built-in Scheme types
+
+(define-simple-type :syntax    () #f)
+(define-simple-type :values    () #f)    ;any number of values
+
+(define (value? x) #t)
+(define-simple-type :value     (:values) value?)
+(define-simple-type :zero      (:values) (lambda (x) #f))
+
+(define-simple-type :number    (:value) number?)
+(define-simple-type :complex   (:number) complex?)
+(define-simple-type :real      (:complex) real?)
+(define-simple-type :rational  (:real) rational?)
+(define-simple-type :integer   (:rational) integer?)
+(define-simple-type :exact-integer (:integer)
+  (lambda (n) (and (integer? n) (exact? n))))
+
+(define-simple-type :boolean   (:value) boolean?)
+(define-simple-type :symbol    (:value) symbol?)
+(define-simple-type :char      (:value) char?)
+(define-simple-type :null      (:value) null?)
+(define-simple-type :pair      (:value) pair?)
+(define-simple-type :vector    (:value) vector?)
+(define-simple-type :string    (:value) string?)
+(define-simple-type :procedure (:value) procedure?)
+
+(define-simple-type :input-port  (:value) input-port?)
+(define-simple-type :output-port (:value) output-port?)
+(define-simple-type :eof-object	 (:value) eof-object?)
+
+; If there is no RECORD? predicate, do
+;   (define-simple-type :record	 (:value) value?)
+; and change the DISCLOSE method for records to
+;   (or (disclose-record obj) (next-method)).
+
+(define-simple-type :record	 (:value) record?)
+
+; If record types are not records, un-comment the following line.
+; (define-simple-type :record-type (:value) record-type?)
+
+; Given a record type, RECORD-TYPE-PRIORITY returns its priority.
+; Here we establish that every record type is a direct subtype of the
+; :RECORD type.
+
+(define record-type-priority
+  (let ((r-priority
+	 (simple-type-priority (make-simple-type (list :record) #f #f))))
+    (lambda (rt) r-priority)))
+
+; --------------------
+; Method-info records are triples <type-list, n-ary?, proc>.
+
+(define-record-type method-info :method-info
+  (really-make-method-info types n-ary? proc)
+  method-info?
+  (types method-info-types)
+  (n-ary? method-info-n-ary?)
+  (proc method-info-proc))
+
+(define (make-method-info types n-ary? proc)
+  (make-immutable! (really-make-method-info types n-ary? proc)))
+
+(define-record-discloser :method-info
+  (lambda (info)
+    `(method-info ,(method-info-types info) ,(method-info-n-ary? info))))
+
+; --------------------
+; Method lists
+
+; A method list is a list of method-info records, sorted in order from
+; most specific to least specific.
+
+(define (empty-method-list) '())
+
+; insert-method inserts an entry into a method list so that the most
+; specific methods come earliest in the list.  The last method should
+; be a default method or error signal(l)er.
+
+(define (insert-method info ms)
+  (let recur ((ms ms))
+    (if (null? ms)
+	(cons info ms)
+	(if (more-specific? (car ms) info)
+	    (cons (car ms) (recur (cdr ms)))
+	    (cons info
+		  (if (same-applicability? (car ms) info)
+		      (cdr ms)
+		      ms))))))
+
+; Replace an existing method with identical domain.
+
+(define (same-applicability? info1 info2)
+  (and (every2 %same-type?
+	       (method-info-types info1)
+	       (method-info-types info2))
+       (eq? (method-info-n-ary? info1) (method-info-n-ary? info2))))
+
+(define (every2 pred l1 l2)
+  (if (null? l1)
+      (null? l2)
+      (if (null? l2)
+	  #f
+	  (and (pred (car l1) (car l2)) (every2 pred (cdr l1) (cdr l2))))))
+
+; This interacts with methods->perform, below.
+; In this version, it's supposed to be a total order.
+
+(define (more-specific? info1 info2)
+  (let ((t1 (method-info-types info1))
+	(t2 (method-info-types info2)))
+    (let ((l1 (length t1))
+	  (l2 (length t2))
+	  (foo? (and (not (method-info-n-ary? info1))
+		     (method-info-n-ary? info2))))
+      (if (= l1 l2)
+	  (or foo?
+	      (let loop ((l1 t1)
+			 (l2 t2))
+		(if (null? l2)
+		    #f
+		    (or (more-specific-type? (car l1) (car l2))
+			(and (%same-type? (car l1) (car l2))
+			     (loop (cdr l1) (cdr l2)))))))
+	  (and (> l1 l2)
+	       foo?)))))
+  
+
+(define (more-specific-type? t1 t2)
+  (> (%type-priority t1) (%type-priority t2)))
+
+; --------------------
+; A method table is a cell that contains a method list.
+; Note that the method table is not reachable from the generic
+; procedure.  This means good things for the GC.
+
+(define-record-type method-table :method-table
+  (really-make-method-table methods prototype
+			    generic get-perform set-perform! id)
+  method-table?
+  (methods method-table-methods set-method-table-methods!)
+  (prototype method-table-prototype)
+  (generic make-generic)
+  (get-perform method-table-get-perform)
+  (set-perform! method-table-set-perform!)
+  (id method-table-id))
+
+(define-record-discloser :method-table
+  (lambda (t) `(method-table ,(method-table-id t))))
+
+(define (make-method-table id . option)
+  (let* ((prototype (if (null? option)
+			(make-method-info '() #t #f)
+			(car option)))
+	 (mtable (call-with-values make-cell-for-generic
+		   (lambda (generic get-perform set-perform!)
+		     (really-make-method-table '()
+					       prototype
+					       generic
+					       get-perform
+					       set-perform!
+					       id)))))
+    (set-final-method!
+         mtable
+	 (lambda (next-method . args)
+	   (apply call-error "invalid or unimplemented operation"
+		  id args)))
+    mtable))
+
+(define (make-cell-for-generic)
+  (let ((perform #f))
+    ;; PERFORM always caches (METHODS->PERFORM method-list prototype).
+    (values (lambda args (perform args)) ;Generic proc
+	    (lambda () perform)
+	    (lambda (new) (set! perform new)))))
+
+(define (add-to-method-table! mtable info)
+  (let ((l (insert-method info (method-table-methods mtable))))
+    (set-method-table-methods! mtable l)
+    ((method-table-set-perform! mtable)
+     (methods->perform l (method-table-prototype mtable)))))
+
+(define (set-final-method! mtable proc)
+  (add-to-method-table! mtable
+			(make-method-info '()
+					  #t
+					  proc)))
+
+(define (apply-generic mtable args)
+  ;; (apply (make-generic mtable) args)
+  (((method-table-get-perform mtable)) args)) ;+++
+
+; DEFINE-GENERIC
+
+(define-syntax define-generic
+  (syntax-rules ()
+    ((define-generic ?name ?mtable-name)
+     (begin (define ?mtable-name (make-method-table '?name))
+	    (define ?name (make-generic ?mtable-name))))
+    ((define-generic ?name ?mtable-name (?spec . ?specs))
+     (begin (define ?mtable-name
+	      (make-method-table '?name
+				 (method-info ?name ("next" next-method
+							    ?spec . ?specs)
+				   (next-method))))
+	    (define ?name (make-generic ?mtable-name))))))
+
+; --------------------
+; Method combination.
+
+; Here is the specification:
+
+;(define (apply-generic mtable args)
+;  (let loop ((ms (method-table-methods mtable)))
+;    (let ((next-method (lambda () (loop (cdr ms)))))
+;      (if (let test ((ts (method-info-types (car ms)))
+;                     (args args))
+;            (if (null? ts)
+;                (or (null? args)
+;                    (method-info-n-ary? (car ms)))
+;                (and ((%type-predicate (car ts)) (car args))
+;                     (test (cdr ts) (cdr args)))))
+;          (apply (method-info-proc (car ms))
+;                 next-method
+;                 args)
+;          (next-method)))))
+
+;   (perform arg-list)
+;   (apply proc next-method-thunk arg-list)
+
+; This version of METHODS->PERFORM simply marches through all the
+; methods, looking for one that handles the operation.
+
+; The prototype is currently ignored, but it could be put to good use.
+
+(define (methods->perform l prototype)
+  (let recur ((l l))
+    (let* ((info (car l))
+	   (proc (method-info-proc info)))
+      (if (null? (cdr l))
+	  (last-action proc)
+	  (one-action (argument-sequence-predicate info)
+		      proc
+		      (recur (cdr l)))))))
+
+(define (last-action proc)
+  (lambda (args)
+    (apply proc #f args)))
+
+(define (one-action pred proc perform-next)
+  (lambda (args)
+    (if (pred args)
+	(apply proc
+	       (lambda () (perform-next args))    ; next-method
+	       args)
+	(perform-next args))))
+
+(define (argument-sequence-predicate info)
+  (let recur ((types (method-info-types info)))
+    (if (null? types)
+	(if (method-info-n-ary? info) value? null?)
+	(let ((pred (%type-predicate (car types)))
+	      (check-rest (recur (cdr types))))
+	  (if (eq? pred value?)
+	      (check-for-next check-rest) ;+++
+	      (check-next pred check-rest))))))
+
+(define (check-for-next check-rest)
+  (lambda (args)
+    (if (null? args)
+	#f
+	(check-rest (cdr args)))))
+
+(define (check-next pred check-rest)
+  (lambda (args)
+    (if (null? args)
+	#f
+	(if (pred (car args))
+	    (check-rest (cdr args))
+	    #f))))
+
+; --------------------
+; METHOD-INFO macro.
+; Returns a method-info record.
+
+; You can specify the name of the next-method parameter by saying
+;   (method-info my-name (x y "next" n) body ...)
+; Otherwise, the next-method parameter will be named next-method.
+; Just pretend it's Dylan and that #next reads as "next".
+
+(define-syntax method-info
+  (syntax-rules ()
+    ((method-info ?id ?formals ?body ...)
+     (method-internal ?formals () () #f ?id ?body ...))))
+
+(define-syntax method-internal
+  (syntax-rules ()
+    ((method-internal ((?formal1 ?type1) . ?specs)
+		      (?formal ...) (?type ...) ?next
+		      . ?rest)
+     (method-internal ?specs
+		      (?formal ... ?formal1) (?type ... ?type1) ?next
+		      . ?rest))
+
+    ((method-internal ("next" ?next . ?specs)
+		      (?formal ...) (?type ...) ?ignore
+		      . ?rest)
+     (method-internal ?specs
+		      (?formal ...) (?type ...) ?next
+		      . ?rest))
+
+    ((method-internal (?spec . ?specs)
+		      (?formal ...) (?type ...) ?next
+		      . ?rest)
+     (method-internal ?specs
+		      (?formal ... ?spec) (?type ... :value) ?next
+		      . ?rest))
+
+    ((method-internal ?rest
+		      (?formal ...) (?type ...) ?next
+		      ?id ?body ...)
+     (make-method-info (list ?type ...)
+		       (not (null? '?rest))
+		       (let ((?id (with-next-method ?next (?formal ... . ?rest)
+				    ?body ...)))
+			 ;; The (let ...) is a hack for the Scheme 48
+			 ;; byte code compiler, which will remember
+			 ;; ?id as the procedure's name.  This should
+			 ;; aid debugging a little bit since the name
+			 ;; shows up in backtraces and the inspector.
+			 ?id)))))
+
+; Non-hygienic, a la Dylan
+
+(define-syntax with-next-method
+  (cons (lambda (e r c)
+	  (let ((next (or (cadr e) 'next-method)))
+	    `(,(r 'lambda) (,next ,@(caddr e))
+			   ,@(cdddr e))))
+	'(lambda)))
+
+; DEFINE-METHOD macro.
+
+(define-syntax define-method
+  (syntax-rules ()
+    ((define-method ?mtable ?formals ?body ...)
+     (add-method! ?mtable
+		  (method-info ?mtable ?formals ?body ...)))))
+
+(define-generic add-method! &add-method! (mtable info))
+
+(let ((info
+       (method-info add-method! ((mtable :method-table) (info :method-info))
+	 (add-to-method-table! mtable info))))
+  (add-to-method-table! &add-method! info))
+
+; --------------------
+; Generic functions on types: sort of a meta-object protocol, huh?
+
+(define-generic type-predicate &type-predicate (t))
+
+(define-method &type-predicate ((t :record-type)) (record-predicate t))
+(define-method &type-predicate ((t :simple-type)) (simple-type-predicate t))
+
+(define-generic type-priority &type-priority (t))
+
+(define-method &type-priority ((t :record-type)) (record-type-priority t))
+(define-method &type-priority ((t :simple-type)) (simple-type-priority t))
+
+(define-generic type-superiors &type-superiors (t))
+
+(define-method &type-superiors ((t :record-type)) (list :record))
+(define-method &type-superiors ((t :simple-type)) (simple-type-superiors t))
+
+
+; Type equivalence
+
+(define-generic same-type? &same-type? (t1 t2))
+
+(define-method &same-type? (t1 t2) (eq? t1 t2))
+
+(define-method &same-type? ((t1 :simple-type) (t2 :simple-type))
+  (and (eq? (simple-type-predicate t1) (simple-type-predicate t2))
+       (eq? (simple-type-id t1) (simple-type-id t2))))    ;?
+
+; --------------------
+; Singleton types.
+
+(define-record-type singleton :singleton
+  (singleton value)
+  (value singleton-value))
+  
+(define-record-discloser :singleton
+  (lambda (s) `(singleton ,(singleton-value s))))
+
+(define (compare-to val)
+  (lambda (x) (eqv? x val)))
+
+(define-method &type-predicate ((s :singleton))
+  (compare-to (singleton-value s)))
+
+(define-method &type-priority ((s :singleton)) 1000000)
+
+(define-method &same-type? ((s1 :singleton) (s2 :singleton))
+  (eqv? (singleton-value s1) (singleton-value s2)))
+
+; --------------------
+; DISCLOSE
+
+; A generic procedure for producing printed representations.
+; Should return one of
+;   - A list (symbol info ...), to be printed as #{Symbol info ...}
+;   - #f, meaning no information available on how to print.
+; This is intended to be used not only by write and display, but also by
+; the pretty printer.
+
+(define-generic disclose &disclose (x))
+
+(define-method &disclose (obj) #f)
+
+(define-method &disclose ((obj :record))
+  (or (disclose-record obj)
+      '(record)))
+
+(define-method &add-method! ((d (singleton &disclose)) info)
+  (let ((t (car (method-info-types info))))
+    (if (record-type? t)
+	(define-record-discloser t (proc->discloser (method-info-proc info)))
+	(next-method))))
+
+(define (proc->discloser proc)
+  (lambda (arg)
+    (proc (lambda () #f) arg)))
+
+;(define-method &disclose ((s :singleton))
+;  `(singleton ,(singleton-value s)))
diff --git a/scheme/rts/number.scm b/scheme/rts/number.scm
new file mode 100644
index 0000000..51d0ba0
--- /dev/null
+++ b/scheme/rts/number.scm
@@ -0,0 +1,82 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; This is file number.scm.
+
+
+;;;; Numbers
+
+(define (inexact? n) (not (exact? n)))
+
+(define (modulo x y)
+   (let ((r (remainder x y)))
+      (if (> y 0)
+	  (if (< r 0)
+	      (+ r y)
+	      r)
+	  (if (> r 0)
+	      (+ r y)
+	      r))))
+
+(define (ceiling x)
+  (- 0 (floor (- 0 x))))		;floor is primitive
+
+(define (truncate x)
+  (if (< x 0)
+      (ceiling x)
+      (floor x)))
+
+(define (round x)
+  (let* ((x+1/2 (+ x (/ 1 2)))
+	 (r (floor x+1/2)))
+    (if (and (= r x+1/2)
+	     (odd? r))
+	(- r 1)
+	r)))
+	
+; GCD
+
+(define (gcd . integers)
+  (reduce (lambda (x y)
+	    (cond ((< x 0) (gcd (- 0 x) y))
+		  ((< y 0) (gcd x (- 0 y)))
+		  ((< x y) (euclid y x))
+		  (else (euclid x y))))
+	  0
+	  integers))
+
+(define (euclid x y)
+  (if (= y 0)
+      (if (and (inexact? y)
+	       (exact? x))
+	  (exact->inexact x)
+	  x)
+      (euclid y (remainder x y))))
+
+; LCM
+
+(define (lcm . integers)
+  (reduce (lambda (x y)
+	    (let ((g (gcd x y)))
+	      (cond ((= g 0) g)
+		    (else (* (quotient (abs x) g) (abs y))))))
+	  1
+	  integers))
+
+; Exponentiation.
+
+(define (expt x n)
+  (if (and (integer? n) (exact? n))
+      (if (>= n 0)
+	  (raise-to-integer-power x n)
+	  (/ 1 (raise-to-integer-power x (- 0 n))))
+      (exp (* n (log x)))))
+
+(define (raise-to-integer-power x n)
+  (if (= n 0)
+      1
+      (let loop ((s x) (i n) (a 1))	;invariant: a * s^i = x^n
+	(let ((a (if (odd? i) (* a s) a))
+	      (i (quotient i 2)))
+	  (if (= i 0)
+	      a
+	      (loop (* s s) i a))))))
diff --git a/scheme/rts/numio.scm b/scheme/rts/numio.scm
new file mode 100644
index 0000000..9c6261f
--- /dev/null
+++ b/scheme/rts/numio.scm
@@ -0,0 +1,196 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+;;;; number->string and string->number
+
+; NUMBER->STRING
+
+(define-generic real-number->string &number->string)
+
+(define (number->string number . maybe-radix)
+  (let ((radix (if (null? maybe-radix)
+		   10
+		   (car maybe-radix))))
+    (if (and (number? number)
+	     (or (null? maybe-radix)
+		 (and (null? (cdr maybe-radix))
+		      (integer? radix)
+		      (exact? radix)
+		      (< 0 radix))))
+	(real-number->string number radix)
+	(apply call-error
+	       "invalid argument"
+	       'number->string
+	       number
+	       maybe-radix))))
+
+(define-method &number->string (n radix)
+  (call-error "invalid argument"
+	      'number->string
+	      n
+	      radix))
+
+(define-method &number->string ((n :exact-integer) radix)
+  (integer->string n radix))
+
+(define integer->string    ;Won't necessarily work if n is inexact
+  (let ()
+
+    (define (integer->string n radix)
+      (let ((magnitude
+	     (if (= n 0)
+		 (list #\0)
+		 (let recur ((n n) (l '()))
+		   (if (= n 0)
+		       l
+		       (recur (quotient n radix)
+			      (cons (integer->digit (abs (remainder n radix)))
+				    l)))))))
+	(list->string (if (>= n 0)
+			  magnitude
+			  (cons #\- magnitude)))))
+
+    (define (integer->digit n)
+      (ascii->char (+ n (if (< n 10)
+			    zero
+			    a-minus-10))))
+
+    (define zero (char->ascii #\0))
+    (define a-minus-10 (- (char->ascii #\a) 10))
+
+    integer->string))
+
+
+; STRING->NUMBER
+
+; This just strips off any # prefixes and hands the rest off to
+; really-string->number, which is generic.
+
+(define (string->number string . options)
+  (if (not (string? string))
+      (apply call-error "invalid argument"
+	     'string->number
+	     string options))
+  (let* ((radix (cond ((null? options) 10)
+		      ((null? (cdr options)) (car options))
+		      ;; Revised^3 Scheme compatibility
+		      (else (cadr options))))
+	 (radix (case radix
+		  ((2 8 10 16) radix)
+		  ((b) 2) ((o) 8) ((d) 10) ((x) 16)    ;R3RS only?
+		  (else (call-error "invalid radix"
+				    'string->number
+				    string radix))))
+	 (len (string-length string)))
+    (let loop ((pos 0) (exactness? #f) (exact? #t) (radix? #f) (radix radix))
+      (cond ((>= pos len)
+	     #f)
+	    ((char=? (string-ref string pos) #\#)
+	     (let ((pos (+ pos 1)))
+	       (if (>= pos len)
+		   #f
+		   (let ((radix-is
+			  (lambda (radix)
+			    (if radix?
+				#f
+				(loop (+ pos 1) exactness? exact? #t radix))))
+			 (exactness-is
+			  (lambda (exact?)
+			    (if exactness?
+				#f
+				(loop (+ pos 1) #t exact? radix? radix)))))
+		     (case (char-downcase (string-ref string pos))
+		       ((#\b) (radix-is 2))
+		       ((#\o) (radix-is 8))
+		       ((#\d) (radix-is 10))
+		       ((#\x) (radix-is 16))
+		       ((#\e) (exactness-is #t))
+		       ((#\i) (exactness-is #f))
+		       (else #f))))))
+	    (else
+	     (really-string->number
+	        (substring string pos len)
+		radix
+		(if exactness?
+		    exact?
+		    (let loop ((pos pos))
+		      (cond ((>= pos len) #t) ;exact
+			    ((char=? (string-ref string pos) #\.)
+			     (if (not (= radix 10))
+				 (warn "non-base-10 number has decimal point"
+				       string))
+			     #f)	;inexact
+			    ((char=? (string-ref string pos) #\#)
+			     #f)
+			    (else (loop (+ pos 1))))))))))))
+
+(define-generic really-string->number &really-string->number)
+
+(define-method &really-string->number (string radix xact?) #f)
+
+
+; Read exact integers
+
+(define-simple-type :integer-string (:string)
+  (lambda (s)
+    (and (string? s)
+	 (let loop ((i (- (string-length s) 1)))
+	   (if (< i 0)
+	       #t
+	       (let ((c (string-ref s i)))
+		 (and (or (char-numeric? c)
+			  (and (char>=? c #\a)
+			       (char<=? c #\f))
+			  (and (char>=? c #\A)
+			       (char<=? c #\F))
+			  (and (= i 0)
+			       (or (char=? c #\+) (or (char=? c #\-)))))
+		      (loop (- i 1)))))))))
+
+(define-method &really-string->number ((string :integer-string) radix xact?)
+  (let ((n (string->integer string radix)))
+    (if n (set-exactness n xact?) #f)))
+
+(define (set-exactness n xact?)
+  (if (exact? n)
+      (if xact? n (exact->inexact n))
+      (if xact? (inexact->exact n) n)))
+
+(define string->integer
+  (let ()
+
+    (define (string->integer string radix)
+      (cond ((= (string-length string) 0) #f)
+	    ((char=? (string-ref string 0) #\+)
+	     (do-it string 1 1 radix))
+	    ((char=? (string-ref string 0) #\-)
+	     (do-it string 1 -1 radix))
+	    (else
+	     (do-it string 0 1 radix))))
+
+    (define (do-it string pos sign radix)
+      (let* ((len (string-length string)))
+	(if (>= pos len)
+	    #f
+	    (let loop ((n 0) (pos pos))
+	      (if (>= pos len)
+		  n
+		  (let ((d (digit->integer (string-ref string pos)
+					   radix)))
+		    (if d
+			(loop (+ (* n radix) (* sign d))
+			      (+ pos 1))
+			#f)))))))
+
+    (define (digit->integer c radix)
+      (cond ((char-numeric? c)
+	     (let ((n (- (char->ascii c) zero)))
+	       (if (< n radix) n #f)))
+	    ((<= radix 10) #f)
+	    (else
+	     (let ((n (- (char->ascii (char-downcase c)) a-minus-ten)))
+	       (if (and (>= n 10) (< n radix)) n #f)))))
+    
+    (define zero (char->ascii #\0))
+    (define a-minus-ten (- (char->ascii #\a) 10))
+
+    string->integer))
diff --git a/scheme/rts/population.scm b/scheme/rts/population.scm
new file mode 100644
index 0000000..df89ffe
--- /dev/null
+++ b/scheme/rts/population.scm
@@ -0,0 +1,37 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+
+
+(define (make-population)
+  (list '<population>))
+
+(define (add-to-population! x pop)
+  (if (not x) (error "can't put #f in a population"))
+  (if (not (weak-memq x (cdr pop)))
+      (set-cdr! pop (cons (make-weak-pointer x) (cdr pop)))))
+
+(define (weak-memq x weaks)
+  (if (null? weaks)
+      #f
+      (if (eq? x (weak-pointer-ref (car weaks)))
+	  weaks
+	  (weak-memq x (cdr weaks)))))
+
+(define (population-reduce cons nil pop)
+  (do ((l (cdr pop) (cdr l))
+       (prev pop l)
+       (m nil (let ((w (weak-pointer-ref (car l))))
+		(if w
+		    (cons w m)
+		    (begin (set-cdr! prev (cdr l))
+			   m)))))
+      ((null? l) m)))
+
+(define (population->list pop)
+  (population-reduce cons '() pop))
+
+(define (walk-population proc pop)
+  (population-reduce (lambda (thing junk) (proc thing))
+		     #f
+		     pop))
diff --git a/scheme/rts/port.scm b/scheme/rts/port.scm
new file mode 100644
index 0000000..68eb40f
--- /dev/null
+++ b/scheme/rts/port.scm
@@ -0,0 +1,603 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Ports and port handlers
+
+; See doc/io.txt for a description of the i/o system, including ports,
+; port handlers, and so forth.
+
+(define-record-type port-handler :port-handler
+  (make-port-handler discloser close buffer-proc)
+  port-handler?
+  (discloser   port-handler-discloser)
+  (close       port-handler-close)
+  (buffer-proc port-handler-buffer-proc))
+
+(define (disclose-port port)
+  ((port-handler-discloser (port-handler port)) (port-data port)))
+
+(define-method &disclose ((port :input-port))
+  (disclose-port port))
+
+(define-method &disclose ((port :output-port))
+  (disclose-port port))
+
+; The PORT-LOCKED? bit is checked by READ-CHAR, PEEK-CHAR, and WRITE-CHAR
+; which are too simple-minded to understand real locks.  The three procedures
+; below ensure that (PORT-LOCKED? <port>) is #t whenever someone has aquired
+; <port>'s lock.
+
+(define (obtain-port-lock port)
+  (set-port-locked?! port #t)
+  (obtain-lock (port-lock port)))
+
+(define (maybe-obtain-port-lock port)
+  (let ((ints (set-enabled-interrupts! 0)))
+    (set-port-locked?! port #t)
+    (let ((result (if (maybe-obtain-lock (port-lock port))
+		      #t
+		      (begin
+			(set-port-locked?! port #f)
+			#f))))
+      (set-enabled-interrupts! ints)
+      result)))
+
+(define (release-port-lock port)
+  (let ((ints (set-enabled-interrupts! 0)))
+    (if (release-lock (port-lock port))
+	(set-port-locked?! port #f))
+    (set-enabled-interrupts! ints)))
+
+; Set up exception handlers for the three unnecessary I/O primitives,
+; READ-CHAR, PEEK-CHAR, and WRITE-CHAR.  These do the right thing in
+; the case of buffer overflow or underflow.
+;
+; This is abstracted to avoid a circular module dependency.
+
+(define (initialize-i/o-handlers! define-exception-handler signal-exception)
+  (define-exception-handler (enum op read-char)
+    (one-arg-proc->handler (read-char-handler #t) signal-exception))
+    
+  (define-exception-handler (enum op peek-char)
+    (one-arg-proc->handler (read-char-handler #f) signal-exception))
+  
+  (define-exception-handler (enum op write-char)
+    (two-arg-proc->handler write-char-handler signal-exception)))
+
+; Check the exception and then lock the port.
+
+(define (one-arg-proc->handler proc signal-exception)
+  (lambda (opcode reason port)
+    (if (= reason (enum exception buffer-full/empty))
+	(begin
+	  (obtain-port-lock port)
+	  (let ((value (proc port)))
+	    (release-port-lock port)
+	    value))
+	(signal-exception opcode reason port))))
+
+; This could combined with on-arg-... if the port were the first argument.
+
+(define (two-arg-proc->handler proc signal-exception)
+  (lambda (opcode reason arg port)
+    (if (= reason (enum exception buffer-full/empty))
+	(begin
+	  (obtain-port-lock port)
+	  (let ((value (proc arg port)))
+	    (release-port-lock port)
+	    value))
+	(signal-exception opcode reason arg port))))
+
+; If a character is available, use it; if there is an EOF waiting, use that;
+; otherwise fill the buffer and go from there.
+
+(define (read-char-handler read?)
+  (lambda (port)
+    (cond ((< (port-index port) (port-limit port))
+	   (let ((index (port-index port)))
+	     (if read?
+		 (set-port-index! port (+ 1 index)))
+	     (ascii->char (code-vector-ref (port-buffer port) index))))
+	  ((port-pending-eof? port)
+	   (if read?
+	       (set-port-pending-eof?! port #f))
+	   (eof-object))
+	  (else
+	   (let ((got (fill-port-buffer! port 'any)))
+	     (cond ((or (eof-object? got)
+			(= 0 got))
+		    (if (not read?)
+			(set-port-pending-eof?! port #t))
+		    (eof-object))
+		   (else
+		    (set-port-index! port (if read? 1 0))
+		    (set-port-limit! port got)
+		    (ascii->char (code-vector-ref (port-buffer port) 0)))))))))
+
+(define (fill-port-buffer! port needed)
+  ((port-handler-buffer-proc (port-handler port))
+   (port-data port)
+   (port-buffer port)
+   0
+   needed))
+
+; Write the character if there is room, or call the handler if there is
+; no actual buffering.  Otherwise use the handler to empty the buffer.
+
+(define (write-char-handler char port)
+  (cond ((< (port-index port) (port-limit port))
+	 (code-vector-set! (port-buffer port)
+			   (port-index port)
+			   (char->ascii char))
+	 (set-port-index! port (+ 1 (port-index port))))
+	((= 0 (port-limit port))
+	 ((port-handler-buffer-proc (port-handler port)) (port-data port) char))
+	(else
+	 (empty-port-buffer! port)
+	 (code-vector-set! (port-buffer port) 0 (char->ascii char))
+	 (set-port-index! port 1)))
+  (unspecific))
+
+; This may change PORT's buffer.
+
+(define (empty-port-buffer! port)
+  ((port-handler-buffer-proc (port-handler port))
+   (port-data port)
+   (port-buffer port)
+   0
+   (port-index port))
+  (set-port-index! port 0)
+  (set-port-flushed?! port #t))
+
+(define port-flushed? port-pending-eof?)
+(define set-port-flushed?! set-port-pending-eof?!)
+
+;----------------
+; Closing is done with the appropriate handler.
+; R4RS says that CLOSE-... is idempotent.
+
+(define (close-input-port port)
+  (if (input-port? port)
+      (begin
+	(obtain-port-lock port)
+	(if (open-input-port? port)
+	    (begin
+	      (make-input-port-closed! port)
+	      ((port-handler-close (port-handler port)) (port-data port))))
+	(release-port-lock port))
+      (call-error "invalid argument" close-input-port port)))
+	
+(define (close-output-port port)
+  (if (output-port? port)
+      (begin
+	(obtain-port-lock port)
+	(if (open-output-port? port)
+	    (begin
+	      (really-force-output port)
+	      (make-output-port-closed! port)
+	      ((port-handler-close (port-handler port)) (port-data port))))
+	(release-port-lock port))
+      (call-error "invalid argument" close-output-port port)))
+
+;----------------
+; Port operations that do not have opcodes.  Each of these needs to check its
+; arguments and then lock the port.  A macro is used to add the checking and
+; locking code.  This has to check that the port is a port before locking it
+; and then check that it is open after locking it.
+
+; A macro to handle locking ports and checking that they're open.
+
+(define-syntax define-port-op
+  (syntax-rules ()
+    ((define-port-op (?id ?args ...) ?port ?predicate ?body)
+     (define (?id ?args ...)
+       (if ?predicate                         ; if args are okay
+	   (begin
+	     (obtain-port-lock ?port)         ; lock the port
+	     (if (open-port? ?port)           ; check that it's open
+		 (let ((value ?body))         ; do the work
+		   (release-port-lock ?port)  ; release the lock
+		   value)                     ; return
+		 (begin
+		   (release-port-lock ?port)
+		   (call-error "invalid argument" ?id ?args ...))))
+	   (call-error "invalid argument" ?id ?args ...))))
+
+    ; ?port defaults to the first argument
+    ((define-port-op (?id ?port ?args ...) ?predicate ?body)
+     (define-port-op (?id ?port ?args ...) ?port ?predicate ?body))))
+
+;----------------
+; See if there is a character available.  CHAR-READY? itself is defined
+; in current-ports.scm as it needs CURRENT-INPUT-PORT when called with
+; no arguments.
+
+(define (real-char-ready? port)
+  (cond ((not (open-input-port? port))
+	 (call-error "invalid argument" char-ready? port))
+	((not (maybe-obtain-port-lock port))
+	 #f)
+	((not (open-port? port))  ; have to check again after the lock call
+	 (release-port-lock port)
+	 (call-error "invalid argument" char-ready? port))
+	((or (< (port-index port) (port-limit port))
+	     (port-pending-eof? port))
+	 (release-port-lock port)
+	 #t)
+	(else
+	 (let ((got (fill-port-buffer! port 'immediate)))
+	   (cond ((eof-object? got)
+		  (set-port-pending-eof?! port #t)
+		  (release-port-lock port)
+		  #t)
+		 (else
+		  (set-port-index! port 0)
+		  (set-port-limit! port got)
+		  (release-port-lock port)
+		  (> got 0)))))))
+
+;----------------
+; Check the arguments and the state of the buffer.  Leave any actual work
+; up to the next procedure.
+;
+; The arguments are the same as those for input port handlers: BUFFER is either
+; a string or a code vector, START is the initial index, and COUNT is either
+; the required number of characters, 'ANY (one or more characters wanted),
+; or 'IMMEDIATE (get what's available, but don't block).
+
+(define-port-op (read-block buffer start count port) port
+  (and (open-input-port? port)
+       (okay-limits? buffer start (if (or (eq? count 'any)
+					  (eq? count 'immediate))
+				      1
+				      count)))
+  (cond ((port-pending-eof? port)
+	 (set-port-pending-eof?! port #f)
+	 (eof-object))
+	((eq? count 0)
+	 0)
+	(else
+	 (really-read-block buffer start count port))))
+
+; If nothing is available, call the port's handler procedure.  Otherwise,
+; copy any available characters into the buffer.  If more are needed the
+; buffer handler is called.
+
+(define (really-read-block buffer start count port)
+  (let ((have (- (port-limit port) (port-index port))))
+    (if (= have 0)
+	((port-handler-buffer-proc (port-handler port))
+	   (port-data port)
+	   buffer
+	   start
+	   count)
+	(let ((move (min have
+			 (if (symbol? count)
+			     (- (buffer-length buffer) start)
+			     count))))
+	  (copy-bytes! (port-buffer port) (port-index port) buffer start move)
+	  (set-port-index! port (+ (port-index port) move))
+	  (if (or (symbol? count)
+		  (= move count))
+	      move
+	      (read-more buffer start count port move))))))
+
+(define (buffer-length buffer)
+  (if (string? buffer)
+      (string-length buffer)
+      (code-vector-length buffer)))
+
+(define (read-more buffer start count port have)
+  (let ((more ((port-handler-buffer-proc (port-handler port))
+	         (port-data port)
+		 buffer
+		 (+ start have)
+		 (- count have))))
+    (if (eof-object? more)
+	(if (= 0 have)
+	    (eof-object)
+	    (begin
+	      (set-port-pending-eof?! port #t)
+	      have))
+	(+ more have))))
+    
+; Check that BUFFER contains COUNT characters starting from START.
+
+(define (okay-limits? buffer start count)
+  (and (integer? start)
+       (exact? start)
+       (<= 0 start)
+       (integer? count)
+       (exact? count)
+       (<= 0 count)
+       (<= (+ start count)
+	   (cond ((string? buffer)
+		  (string-length buffer))
+		 ((code-vector? buffer)
+		  (code-vector-length buffer))
+		 (else
+		  -1)))))
+
+;----------------
+; Write the COUNT bytes beginning at START from BUFFER to PORT.
+
+(define-port-op (write-block buffer start count port) port
+  (and (open-output-port? port)
+       (okay-limits? buffer start count))
+  (if (= 0 (port-limit port))
+      (write-unbuffered-block buffer start count port)
+      (write-buffered-block buffer start count port)))
+
+; WRITE-STRING is a front for WRITE-BLOCK.
+
+(define (write-string string port)
+  (write-block string 0 (string-length string) port))
+
+; Copy the bytes into the buffer if there is room, otherwise write out anything
+; in the buffer and then write BUFFER.
+
+(define (write-buffered-block buffer start count port)
+  (let ((space (- (port-limit port) (port-index port))))
+    (cond ((>= space count)
+	   (copy-bytes! buffer start (port-buffer port) (port-index port) count)
+	   (set-port-index! port (+ (port-index port) count)))
+	  (else
+	   (really-force-output port)
+	   ((port-handler-buffer-proc (port-handler port))
+	    (port-data port) buffer start count)))))
+
+; For unbuffered ports we have to call the handler on each character
+; separately.
+
+(define (write-unbuffered-block buffer start count port)
+  (let ((proc (port-handler-buffer-proc (port-handler port)))
+        (data (port-data port))
+        (string? (string? buffer)))
+    (do ((i 0 (+ i 1)))
+        ((= i count))
+      (proc data (if string?
+                     (string-ref buffer (+ start i))
+                     (ascii->char (code-vector-ref buffer (+ start i))))))))
+
+;----------------
+; Empty the buffer if it contains anything.
+
+(define-port-op (force-output port)
+  (open-output-port? port)
+  (really-force-output port))
+
+(define (really-force-output port)
+  (if (< 0 (port-index port))
+      (empty-port-buffer! port)))
+
+; Used to avoid race conditions elsewhere.
+
+(define (force-output-if-open port)
+  (if (output-port? port)
+      (begin
+	(obtain-port-lock port)
+	(if (open-output-port? port)
+	    (really-force-output port))
+	(release-port-lock port))
+      (call-error "invalid argument" force-output-if-open port)))
+
+;----------------
+
+(define default-buffer-size 4096)  ; should get this from the system
+
+;----------------
+; Is PORT open?
+
+(define (open-port? port)
+  (not (= 0 (bitwise-and open-port-mask (port-status port)))))
+
+(define open-port-mask
+  (bitwise-ior (arithmetic-shift 1 (enum port-status-options open-for-input))
+	       (arithmetic-shift 1 (enum port-status-options open-for-output))))
+
+;----------------
+; Input ports
+
+(define input-port-mask
+  (arithmetic-shift 1 (enum port-status-options input)))
+
+(define open-input-port-mask
+  (arithmetic-shift 1 (enum port-status-options open-for-input)))
+
+(define open-input-port-status
+  (bitwise-ior input-port-mask open-input-port-mask))
+
+(define (open-input-port? port)
+  (not (= 0 (bitwise-and open-input-port-mask (port-status port)))))
+
+(define (make-input-port-closed! port)
+  (set-port-status! port (bitwise-and (port-status port)
+				      (bitwise-not open-input-port-mask))))
+
+(define (make-input-port handler data buffer index limit)
+  (if (and (okay-buffer? buffer index limit)
+	   (port-handler? handler))
+      (make-port handler
+		 (bitwise-ior input-port-mask open-input-port-mask)
+		 (make-lock)
+		 #f             ; locked?
+		 data
+		 buffer
+		 index
+		 limit
+		 #f)            ; pending-eof?
+      (call-error "invalid argument"
+		  make-input-port handler data buffer index limit)))
+
+(define (okay-buffer? buffer index limit)
+  (and (code-vector? buffer)
+       (let ((length (code-vector-length buffer)))
+	 (integer? limit)
+	 (<= 0 limit)
+	 (<= limit length)
+	 (<= index limit)
+	 (integer? index)
+	 (<= 0 index)
+	 (<= index limit))))
+
+;----------------
+; Output ports
+
+(define output-port-mask
+  (arithmetic-shift 1 (enum port-status-options output)))
+
+(define open-output-port-mask
+  (arithmetic-shift 1 (enum port-status-options open-for-output)))
+
+(define open-output-port-status
+  (bitwise-ior output-port-mask open-output-port-mask))
+
+(define (open-output-port? port)
+  (not (= 0 (bitwise-and open-output-port-mask (port-status port)))))
+
+(define (make-output-port-closed! port)
+  (set-port-status! port (bitwise-and (port-status port)
+				      (bitwise-not open-output-port-mask))))
+
+(define (make-output-port handler data buffer index limit)
+  (if (and (okay-buffer? buffer index limit)
+	   (> limit 0)
+	   (port-handler? handler))
+      (make-port handler
+		 open-output-port-status
+		 (make-lock)
+		 #f             ; locked?
+		 data
+		 buffer
+		 index
+		 limit
+		 #f)            ; pending-eof?
+      (call-error "invalid argument"
+		  make-output-port handler data buffer index limit)))
+
+(define (make-unbuffered-output-port handler data)
+  (if (port-handler? handler)
+      (make-port handler
+		 open-output-port-status
+		 (make-lock)
+		 #f             ; locked?
+		 data
+		 (make-code-vector 0 0)
+		 0
+		 0
+		 #f)            ; pending-eof?
+      (call-error "invalid argument"
+		  make-unbuffered-output-port handler data)))
+
+(define null-output-port-handler
+  (make-port-handler
+   (lambda (ignore)
+     (list 'null-output-port))
+   (lambda (ignore)
+     (unspecific))
+   (lambda (channel buffer start need)
+     (unspecific))))
+
+(define (make-null-output-port)
+  (make-port null-output-port-handler
+	     open-output-port-status
+	     (make-lock)    ; wasted
+	     #f             ; locked?
+	     (unspecific)
+	     (make-code-vector 1 0)
+	     0
+	     1              ; if 0 it would look unbuffered
+	     #f))           ; pending-eof?
+
+;----------------
+; Code to periodically flush output ports.
+
+(define *flush-these-ports* (cons #f '()))
+
+(define (initialize-output-port-list!)
+  (set! *flush-these-ports* (cons #f '())))
+
+(define (periodically-force-output! port)
+  (set-cdr! *flush-these-ports*
+	    (cons (make-weak-pointer port) (cdr *flush-these-ports*))))
+
+; Return a list of thunks that will flush the buffer of each open, unlocked
+; port that contains characters that have been there since the last time
+; this was called.  The actual i/o is done using separate threads to keep
+; i/o errors from killing anything vital.
+; 
+; If USE-FLUSHED?-FLAGS? is true this won't flush buffers that have been
+; flushed by someone else sinse the last call.  If it is false then flush
+; all non-empty buffers, because the system has nothing to do and is going
+; to pause while waiting for external events.
+
+(define (output-port-forcers use-flushed?-flags?)
+  (let loop ((next (cdr *flush-these-ports*))
+             (last *flush-these-ports*)
+             (thunks '()))
+    (if (null? next)
+        thunks
+        (let ((port (weak-pointer-ref (car next))))
+          (cond ((or (not port)                      ; GCed or closed
+                     (not (open-output-port? port))) ;  so drop it from the list
+                 (set-cdr! last (cdr next))
+                 (loop (cdr next) last thunks))
+                ((not (maybe-obtain-port-lock port)) ; locked
+                 (loop (cdr next) next thunks))
+                ((and use-flushed?-flags?            ; flushed recently
+                      (port-flushed? port))
+                 (set-port-flushed?! port #f)
+                 (release-port-lock port)
+                 (loop (cdr next) next thunks))
+                ((< 0 (port-index port))              ; non-empty
+                 (release-port-lock port)
+                 (loop (cdr next) next
+		       (cons (make-forcing-thunk port)
+			     thunks)))
+                (else                                 ; empty
+                 (release-port-lock port)
+                 (loop (cdr next) next thunks)))))))
+
+; Returns a list of the current ports that are flushed whenever.
+; This is used to flush channel ports before forking.
+
+(define (periodically-flushed-ports)
+  (let ((ints (set-enabled-interrupts! 0)))
+    (let loop ((next (cdr *flush-these-ports*))
+	       (last *flush-these-ports*)
+	       (ports '()))
+      (if (null? next)
+	  (begin
+	    (set-enabled-interrupts! ints)
+	    ports)
+	  (let ((port (weak-pointer-ref (car next))))
+	    (cond ((or (not port)                      ; GCed or closed
+		       (not (open-output-port? port))) ; so drop it from the list
+		   (set-cdr! last (cdr next))
+		   (loop (cdr next) last ports))
+		  (else
+		   (loop (cdr next)
+			 next
+			 (cons port ports)))))))))
+
+; Write out PORT's buffer.  If a problem occurs it is reported and PORT
+; is closed.
+
+(define (make-forcing-thunk port)
+  (lambda ()
+    (if (and (report-errors-as-warnings
+	      (lambda ()
+		(if (maybe-obtain-port-lock port)
+		    (begin
+		      (really-force-output port)
+		      (release-port-lock port))))
+	      "error when flushing buffer; closing port"
+	      port)
+	     (open-output-port? port))
+	(report-errors-as-warnings
+	   (lambda ()
+	     (make-output-port-closed! port)
+	     ((port-handler-close (port-handler port)) (port-data port)))
+	   "error when closing port"
+	   port))))
+	
+			       
diff --git a/scheme/rts/ratnum.scm b/scheme/rts/ratnum.scm
new file mode 100644
index 0000000..0f0b8cf
--- /dev/null
+++ b/scheme/rts/ratnum.scm
@@ -0,0 +1,141 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; This is file ratnum.scm.
+
+; Rational arithmetic
+; Assumes that +, -, etc. perform integer arithmetic.
+
+(define-simple-type :exact-rational (:rational :exact)
+  (lambda (n) (and (rational? n) (exact? n))))
+
+(define-extended-number-type :ratnum (:exact-rational :exact) ;?
+  (make-ratnum num den)
+  ratnum?
+  (num ratnum-numerator)
+  (den ratnum-denominator))
+
+(define (integer/ m n)
+  (cond ((< n 0)
+	 (integer/ (- 0 m) (- 0 n)))
+	((= n 0)
+	  (error "rational division by zero" m))
+	((and (exact? m) (exact? n))
+	 (let ((g (gcd m n)))
+	   (let ((m (quotient m g))
+		 (n (quotient n g)))
+	     (if (= n 1)
+		 m
+		 (make-ratnum m n)))))
+	(else (/ m n))))    ;In case we get flonums
+
+(define (rational-numerator p)
+  (if (ratnum? p)
+      (ratnum-numerator p)
+      (numerator p)))
+
+(define (rational-denominator p)
+  (if (ratnum? p)
+      (ratnum-denominator p)
+      (denominator p)))
+
+; a/b * c/d = a*c / b*d
+
+(define (rational* p q)
+  (integer/ (* (rational-numerator p) (rational-numerator q))
+	    (* (rational-denominator p) (rational-denominator q))))
+
+; a/b / c/d = a*d / b*c
+
+(define (rational/ p q)
+  (integer/ (* (rational-numerator p) (rational-denominator q))
+	    (* (rational-denominator p) (rational-numerator q))))
+
+; a/b + c/d = (a*d + b*c)/(b*d)
+
+(define (rational+ p q)
+  (let ((b (rational-denominator p))
+	(d (rational-denominator q)))
+    (integer/ (+ (* (rational-numerator p) d)
+		 (* b (rational-numerator q)))
+	      (* b d))))
+
+; a/b - c/d = (a*d - b*c)/(b*d)
+
+(define (rational- p q)
+  (let ((b (rational-denominator p))
+	(d (rational-denominator q)))
+    (integer/ (- (* (rational-numerator p) d)
+		 (* b (rational-numerator q)))
+	      (* b d))))
+
+; a/b < c/d  when  a*d < b*c
+
+(define (rational< p q)
+  (< (* (rational-numerator p) (rational-denominator q))
+     (* (rational-denominator p) (rational-numerator q))))
+
+; a/b = c/d  when a = b and c = d  (always lowest terms)
+
+(define (rational= p q)
+  (and (= (rational-numerator p) (rational-numerator q))
+       (= (rational-denominator p) (rational-denominator q))))
+
+; (rational-truncate p) = integer of largest magnitude <= (abs p)
+
+(define (rational-truncate p)
+  (quotient (rational-numerator p) (rational-denominator p)))
+
+; (floor p) = greatest integer <= p
+
+(define (rational-floor p)
+  (let* ((n (numerator p))
+	 (q (quotient n (denominator p))))
+    (if (>= n 0)
+	q
+	(- q 1))))
+
+
+; Extend the generic number procedures
+
+(define-method &rational? ((n :ratnum)) #t)
+
+(define-method &numerator   ((n :ratnum)) (ratnum-numerator n))
+(define-method &denominator ((n :ratnum)) (ratnum-denominator n))
+
+(define-method &exact? ((n :ratnum)) #t)
+
+;(define-method &exact->inexact ((n :ratnum))
+;  (/ (exact->inexact (numerator n))
+;     (exact->inexact (denominator n))))
+
+;(define-method &inexact->exact ((n :rational))  ;?
+;  (/ (inexact->exact (numerator n))
+;     (inexact->exact (denominator n))))
+
+(define-method &/ ((m :exact-integer) (n :exact-integer))
+  (integer/ m n))
+
+(define (define-ratnum-method mtable proc)
+  (define-method mtable ((m :ratnum) (n :exact-rational)) (proc m n))
+  (define-method mtable ((m :exact-rational) (n :ratnum)) (proc m n)))
+
+(define-ratnum-method &+ rational+)
+(define-ratnum-method &- rational-)
+(define-ratnum-method &* rational*)
+(define-ratnum-method &/ rational/)
+(define-ratnum-method &= rational=)
+(define-ratnum-method &< rational<)
+
+(define-method &floor ((m :ratnum)) (rational-floor m))
+
+;(define-method &sqrt ((p :ratnum))
+;  (if (< p 0)
+;      (next-method)
+;      (integer/ (sqrt (numerator p))
+;                (sqrt (denominator p)))))
+
+
+(define-method &number->string ((p :ratnum) radix)
+  (string-append (number->string (ratnum-numerator p) radix)
+		 "/"
+		 (number->string (ratnum-denominator p) radix)))
diff --git a/scheme/rts/read.scm b/scheme/rts/read.scm
new file mode 100644
index 0000000..40bf59b
--- /dev/null
+++ b/scheme/rts/read.scm
@@ -0,0 +1,286 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; A little Scheme reader.
+
+; Nonstandard things used:
+;  Ascii stuff: char->ascii, ascii->char, ascii-whitespaces, ascii-limit
+;    (for dispatch table; portable definitions in alt/ascii.scm)
+;  reverse-list->string  -- ok to define as follows:
+;    (define (reverse-list->string l n)
+;      (list->string (reverse l)))
+;  make-immutable! -- ok to define as follows:
+;    (define (make-immutable! x) x)
+;  signal (only for use by reading-error; easily excised)
+
+
+(define (read . port-option)
+  (let ((port (input-port-option port-option)))
+    (let loop ()
+      (let ((form (sub-read port)))
+        (cond ((not (reader-token? form)) form)
+              ((eq? form close-paren)
+               ;; Too many right parens.
+	       (warn "discarding extraneous right parenthesis")
+               (loop))
+	      (else
+	       (reading-error port (cdr form))))))))
+
+(define (sub-read-carefully port)
+  (let ((form (sub-read port)))
+    (cond ((eof-object? form)
+           (reading-error port "unexpected end of file"))
+	  ((reader-token? form) (reading-error port (cdr form)))
+	  (else form))))
+
+(define reader-token-marker (list 'reader-token))
+(define (make-reader-token message) (cons reader-token-marker message))
+(define (reader-token? form)
+  (and (pair? form) (eq? (car form) reader-token-marker)))
+
+(define close-paren (make-reader-token "unexpected right parenthesis"))
+(define dot         (make-reader-token "unexpected \" . \""))
+
+
+; Main dispatch
+
+(define (sub-read port)
+  (let ((c (read-char port)))
+    (if (eof-object? c)
+        c
+        ((vector-ref read-dispatch-vector (char->ascii c))
+         c port))))
+
+(define read-dispatch-vector
+  (make-vector ascii-limit
+               (lambda (c port)
+                 (reading-error port "illegal character read" c))))
+
+(define read-terminating?-vector
+  (make-vector ascii-limit #t))
+
+(define (set-standard-syntax! char terminating? reader)
+  (vector-set! read-dispatch-vector     (char->ascii char) reader)
+  (vector-set! read-terminating?-vector (char->ascii char) terminating?))
+
+(let ((sub-read-whitespace
+       (lambda (c port)
+         c                              ;ignored
+         (sub-read port))))
+  (for-each (lambda (c)
+              (vector-set! read-dispatch-vector c sub-read-whitespace))
+            ascii-whitespaces))
+
+(let ((sub-read-constituent
+       (lambda (c port)
+	 (parse-token (sub-read-token c port) port))))
+  (for-each (lambda (c)
+              (set-standard-syntax! c #f sub-read-constituent))
+            (string->list
+             (string-append "!$%&*+-./0123456789:<=>?@^_~ABCDEFGHIJKLM"
+                            "NOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"))))
+
+; Usual read macros
+
+(define (set-standard-read-macro! c terminating? proc)
+  (set-standard-syntax! c terminating? proc))
+
+(define (sub-read-list c port)
+  (let ((form (sub-read port)))
+    (if (eq? form dot)
+	(reading-error port
+		       "missing car -- ( immediately followed by .")
+	(let recur ((form form))
+	  (cond ((eof-object? form)
+		 (reading-error port
+				"end of file inside list -- unbalanced parentheses"))
+		((eq? form close-paren) '())
+		((eq? form dot)
+		 (let* ((last-form (sub-read-carefully port))
+			(another-form (sub-read port)))
+		   (if (eq? another-form close-paren)
+		       last-form
+		       (reading-error port
+				      "randomness after form after dot"
+				      another-form))))
+		(else
+		 (cons form (recur (sub-read port)))))))))
+
+(set-standard-read-macro! #\( #t sub-read-list)
+
+(set-standard-read-macro! #\) #t
+  (lambda (c port)
+    c port
+    close-paren))
+
+(set-standard-read-macro! #\' #t
+  (lambda (c port)
+    c
+    (list 'quote (sub-read-carefully port))))
+
+(set-standard-read-macro! #\` #t
+  (lambda (c port)
+    c
+    (list 'quasiquote (sub-read-carefully port))))
+
+(set-standard-read-macro! #\, #t
+  (lambda (c port)
+    c
+    (let* ((next (peek-char port))
+	   ;; DO NOT beta-reduce!
+	   (keyword (cond ((eof-object? next)
+			   (reading-error port "end of file after ,"))
+			  ((char=? next #\@)
+			   (read-char port)
+			   'unquote-splicing)
+			  (else 'unquote))))
+      (list keyword
+            (sub-read-carefully port)))))
+
+(set-standard-read-macro! #\" #t
+  (lambda (c port)
+    c ;ignored
+    (let loop ((l '()) (i 0))
+      (let ((c (read-char port)))
+        (cond ((eof-object? c)
+               (reading-error port "end of file within a string"))
+              ((char=? c #\\)
+               (let ((c (read-char port)))
+		 (cond ((eof-object? c)
+			(reading-error port "end of file within a string"))
+		       ((or (char=? c #\\) (char=? c #\"))
+			(loop (cons c l) (+ i 1)))
+		       (else
+			(reading-error port
+				       "invalid escaped character in string"
+				       c)))))
+              ((char=? c #\")
+	       (reverse-list->string l i))
+              (else
+	       (loop (cons c l) (+ i 1))))))))
+
+(set-standard-read-macro! #\; #t
+  (lambda (c port)
+    c ;ignored
+    (gobble-line port)
+    (sub-read port)))
+
+(define (gobble-line port)
+  (let loop ()
+    (let ((c (read-char port)))
+      (cond ((eof-object? c) c)
+	    ((char=? c #\newline) #f)
+	    (else (loop))))))
+
+(define *sharp-macros* '())
+
+(define (define-sharp-macro c proc)
+  (set! *sharp-macros* (cons (cons c proc) *sharp-macros*)))
+
+(set-standard-read-macro! #\# #f
+  (lambda (c port)
+    c ;ignored
+    (let* ((c (peek-char port))
+	   (c (if (eof-object? c)
+		  (reading-error port "end of file after #")
+		  (char-downcase c)))
+	   (probe (assq c *sharp-macros*)))
+      (if probe
+	  ((cdr probe) c port)
+	  (reading-error port "unknown # syntax" c)))))
+
+(define-sharp-macro #\f
+  (lambda (c port) (read-char port) #f))
+
+(define-sharp-macro #\t
+  (lambda (c port) (read-char port) #t))
+
+(define-sharp-macro #\\
+  (lambda (c port)
+    (read-char port)
+    (let ((c (peek-char port)))
+      (cond ((eof-object? c)
+	     (reading-error port "end of file after #\\"))
+	    ((char-alphabetic? c)
+	     (let ((name (sub-read-carefully port)))
+	       (cond ((= (string-length (symbol->string name)) 1)
+		      c)
+		     ((assq name '((space   #\space)
+				   (newline #\newline)))
+		      => cadr)
+		     (else
+		      (reading-error port "unknown #\\ name" name)))))
+	    (else
+	     (read-char port)
+	     c)))))
+
+(define-sharp-macro #\(
+  (lambda (c port)
+    (read-char port)
+    (list->vector (sub-read-list c port))))
+
+(let ((number-sharp-macro
+       (lambda (c port)
+	 (let ((string (sub-read-token #\# port)))
+	   (or (string->number string)
+	       (reading-error port "unsupported number syntax" string))))))
+  (for-each (lambda (c)
+	      (define-sharp-macro c number-sharp-macro))
+	    '(#\b #\o #\d #\x #\i #\e)))
+
+; Tokens
+
+(define (sub-read-token c port)
+  (let loop ((l (list (preferred-case c))) (n 1))
+    (let ((c (peek-char port)))
+      (cond ((or (eof-object? c)
+                 (vector-ref read-terminating?-vector (char->ascii c)))
+             (reverse-list->string l n))
+            (else
+	     (read-char port)
+             (loop (cons (preferred-case c) l)
+                   (+ n 1)))))))
+
+(define (parse-token string port)
+  (if (let ((c (string-ref string 0)))
+	(or (char-numeric? c) (char=? c #\+) (char=? c #\-) (char=? c #\.)))
+      (cond ((string->number string))
+	    ((member string strange-symbol-names)
+	     (string->symbol (make-immutable! string)))
+	    ((string=? string ".")
+	     dot)
+	    (else
+	     (reading-error port "unsupported number syntax" string)))
+      (string->symbol (make-immutable! string))))
+
+(define strange-symbol-names
+  '("+" "-" "..."
+	"1+" "-1+"  ;Only for S&ICP support
+	"->"	    ;Only for JAR's thesis
+	))
+
+;--- This loses because the compiler won't in-line it.  Hacked by hand
+; because it is in READ's inner loop.
+;(define preferred-case
+;  (if (char=? (string-ref (symbol->string 't) 0) #\T)
+;      char-upcase
+;      char-downcase))
+
+(define p-c-v (make-string ascii-limit #\0))
+
+(let ((p-c (if (char=? (string-ref (symbol->string 't) 0) #\T)
+	       char-upcase
+	       char-downcase)))
+  (do ((i 0 (+ i 1)))
+      ((>= i ascii-limit))
+    (string-set! p-c-v i (p-c (ascii->char i)))))
+
+(define (preferred-case c)
+  (string-ref p-c-v (char->ascii c)))
+
+; Reader errors
+
+(define (reading-error port message . irritants)
+  (apply signal 'read-error message
+	 (append irritants (list port))))
diff --git a/scheme/rts/recnum.scm b/scheme/rts/recnum.scm
new file mode 100644
index 0000000..f7ddb16
--- /dev/null
+++ b/scheme/rts/recnum.scm
@@ -0,0 +1,117 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Rectangular complex arithmetic built on real arithmetic.
+
+(define-extended-number-type :recnum (:complex)
+  (make-recnum real imag)
+  recnum?
+  (real recnum-real-part)
+  (imag recnum-imag-part))
+
+(define (rectangulate x y)    ; Assumes (eq? (exact? x) (exact? y))
+  (if (= y 0)
+      x
+      (make-recnum x y)))
+
+(define (rectangular-real-part z)
+  (if (recnum? z)
+      (recnum-real-part z)
+      (real-part z)))
+
+(define (rectangular-imag-part z)
+  (if (recnum? z)
+      (recnum-imag-part z)
+      (imag-part z)))
+
+(define (rectangular+ a b)
+  (rectangulate (+ (rectangular-real-part a) (rectangular-real-part b))
+		(+ (rectangular-imag-part a) (rectangular-imag-part b))))
+
+(define (rectangular- a b)
+  (rectangulate (- (rectangular-real-part a) (rectangular-real-part b))
+		(- (rectangular-imag-part a) (rectangular-imag-part b))))
+
+(define (rectangular* a b)
+  (let ((a1 (rectangular-real-part a))
+	(a2 (rectangular-imag-part a))
+	(b1 (rectangular-real-part b))
+	(b2 (rectangular-imag-part b)))
+    (rectangulate (- (* a1 b1) (* a2 b2))
+		  (+ (* a1 b2) (* a2 b1)))))
+
+(define (rectangular/ a b)
+  (let ((a1 (rectangular-real-part a))
+	(a2 (rectangular-imag-part a))
+	(b1 (rectangular-real-part b))
+	(b2 (rectangular-imag-part b)))
+    (let ((d (+ (* b1 b1) (* b2 b2))))
+      (rectangulate (/ (+ (* a1 b1) (* a2 b2)) d)
+		    (/ (- (* a2 b1) (* a1 b2)) d)))))
+
+(define (rectangular= a b)
+  (let ((a1 (rectangular-real-part a))
+	(a2 (rectangular-imag-part a))
+	(b1 (rectangular-real-part b))
+	(b2 (rectangular-imag-part b)))
+    (and (= a1 b1) (= a2 b2))))
+
+
+; Methods
+
+(define-method &complex? ((z :recnum)) #t)
+
+(define-method &real-part ((z :recnum)) (recnum-real-part z))
+(define-method &imag-part ((z :recnum)) (recnum-imag-part z))
+
+; Methods on complexes in terms of real-part and imag-part
+
+(define-method &exact? ((z :recnum))
+  (exact? (recnum-real-part z)))
+
+(define-method &inexact->exact ((z :recnum))
+  (make-recnum (inexact->exact (recnum-real-part z))
+	       (inexact->exact (recnum-imag-part z))))
+
+(define-method &exact->inexact ((z :recnum))
+  (make-recnum (exact->inexact (recnum-real-part z))
+	       (exact->inexact (recnum-imag-part z))))
+
+(define (define-recnum-method mtable proc)
+  (define-method mtable ((m :recnum) (n :complex)) (proc m n))
+  (define-method mtable ((m :complex) (n :recnum)) (proc m n)))
+
+(define-recnum-method &+ rectangular+)
+(define-recnum-method &- rectangular-)
+(define-recnum-method &* rectangular*)
+(define-recnum-method &/ rectangular/)
+(define-recnum-method &= rectangular=)
+
+(define-method &sqrt ((n :real))
+  (if (< n 0)
+      (make-rectangular 0 (sqrt (- 0 n)))
+      (next-method)))			; not that we have to
+
+; Gleep!  Can we do quotient and remainder on Gaussian integers?
+; Can we do numerator and denominator on complex rationals?
+
+(define-method &number->string ((z :recnum) radix)
+  (let ((x (real-part z))
+	(y (imag-part z)))
+    (let ((r (number->string x radix))
+	  (i (number->string (abs y) radix))
+	  (& (if (< y 0) "-" "+")))
+      (if (and (inexact? y)		;gross
+	       (char=? (string-ref i 0) #\#))
+	  (string-append (if (char=? (string-ref r 0) #\#)
+			     ""
+			     "#i")
+			 r &
+			 (substring i 2 (string-length i))
+			 "i")
+	  (string-append r & i "i")))))
+
+(define-method &make-rectangular ((x :real) (y :real))
+  (if (eq? (exact? x) (exact? y))
+      (rectangulate x y)
+      (rectangulate (if (exact? x) (exact->inexact x) x)
+		    (if (exact? y) (exact->inexact y) y))))
diff --git a/scheme/rts/record.scm b/scheme/rts/record.scm
new file mode 100644
index 0000000..d640a7e
--- /dev/null
+++ b/scheme/rts/record.scm
@@ -0,0 +1,208 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+;;;; Records
+
+; Every record in the image is assumed to be made either by MAKE-RECORD-TYPE
+; or by a procedure returned by record-constructor.  A record-type is a
+; record that describes a type of record.  At the end of the file we create
+; a record type that describes record types.
+
+; Every record has a record type (another record) in the first slot.
+
+(define (record-type r)
+  (record-ref r 0))
+
+; We number the record types for debugging purposes.
+
+(define *record-type-uid* -1)
+
+; This is the record type that describes record types.  It is set a the end
+; of the file.  Its first slot points to itself.
+
+(define *record-type* #f)
+
+; Make a record type from a name, used for printing and debugging, and
+; a list of field names.
+;
+; The VM references both the record type and the resumer, so their offsets
+; should not be changed.
+
+(define (make-record-type name field-names)
+  (set! *record-type-uid* (+ *record-type-uid* 1))
+  (let ((r (make-record 7 (unspecific))))
+    (record-set! r 0 *record-type*)
+    (record-set! r 1 default-record-resumer)
+    (record-set! r 2 *record-type-uid*)
+    (record-set! r 3 name)
+    (record-set! r 4 field-names)
+    (record-set! r 5 (length field-names))
+    (record-set! r 6 (make-default-record-discloser name))
+    r))
+
+(define (record-type? obj)
+  (and (record? obj)
+       (eq? (record-type obj) *record-type*)))
+
+; The various fields in a record type.
+
+(define (record-type-resumer rt)          (record-ref rt 1))
+(define (set-record-type-resumer! rt r)   (record-set! rt 1 r))
+(define (record-type-uid rt)              (record-ref rt 2))
+(define (record-type-name rt)             (record-ref rt 3))
+(define (record-type-field-names rt)      (record-ref rt 4))
+(define (record-type-number-of-fields rt) (record-ref rt 5))
+(define (record-type-discloser rt)        (record-ref rt 6))
+(define (set-record-type-discloser! rt d) (record-set! rt 6 d))
+
+; This is a hack; it is read by the script that makes c/scheme48.h.
+
+(define record-type-fields
+  '(resumer uid name field-names number-of-fields discloser))
+
+;----------------
+; Given a record type and the name of a field, return the field's index.
+
+(define (record-field-index rt name)
+  (let loop ((names (record-type-field-names rt))
+	     (i 1))
+    (cond ((null? names)
+	   (error "unknown field"
+		  (record-type-name rt)
+		  name))
+	  ((eq? name (car names))
+	   i)
+	  (else
+	   (loop (cdr names) (+ i 1))))))
+
+; Return procedure for contstruction records of type RT.  NAMES is a list of
+; field names which the constructor will take as arguments.  Other fields are
+; uninitialized.
+
+(define (record-constructor rt names)
+  (let ((indexes (map (lambda (name)
+			(record-field-index rt name))
+		      names))
+	(size (+ 1 (record-type-number-of-fields rt))))
+    (lambda args
+      (let ((r (make-record size (unspecific))))
+	(record-set! r 0 rt)
+	(let loop ((is indexes) (as args))
+	  (if (null? as)
+	      (if (null? is)
+		  r
+		  (error "too few arguments to record constructor"
+			 rt names args))
+	      (if (null? is)
+		  (error "too many arguments to record constructor"
+			 rt names args)
+		  (begin (record-set! r (car is) (car as))
+			 (loop (cdr is) (cdr as))))))))))
+
+; Making accessors, modifiers, and predicates for record types.
+
+(define (record-accessor rt name)
+  (let ((index (record-field-index rt name))
+	(error-cruft `(record-accessor ,rt ',name)))
+    (lambda (r)
+      (if (eq? (record-type r) rt)
+	  (record-ref r index)
+	  (call-error "invalid record access" error-cruft r)))))
+
+(define (record-modifier rt name)
+  (let ((index (record-field-index rt name))
+	(error-cruft `(record-modifier ,rt ',name)))
+    (lambda (r x)
+      (if (eq? (record-type r) rt)
+	  (record-set! r index x)
+	  (call-error "invalid record modification" error-cruft r x)))))
+
+(define (record-predicate rt)
+  (lambda (x)
+    (and (record? x)
+	 (eq? (record-type x) rt))))
+
+;----------------
+; A discloser is a procedure that takes a record of a particular type and
+; returns a list whose head is a string or symbol and whose tail is other
+; stuff.
+;
+; Set the discloser for record type RT.
+
+(define (define-record-discloser rt proc)
+  (if (and (record-type? rt)
+	   (procedure? proc))
+      (set-record-type-discloser! rt proc)
+      (call-error "invalid argument" define-record-discloser rt proc)))
+
+; By default we just return the name of the record type.
+
+(define (make-default-record-discloser record-type-name)
+  (lambda (r)
+    (list record-type-name)))
+
+; DISCLOSE-RECORD calls the record's discloser procedure to obtain a list.
+
+(define (disclose-record r)
+  (if (record? r)
+      (let ((rt (record-type r)))
+	(if (record-type? rt)
+	    ((record-type-discloser rt) r)
+	    #f))
+      #f))
+
+;----------------
+; A resumer is a procedure that the VM calls on all records of a given
+; type on startup.
+;
+; A resumer may be:
+;  #t -> do nothing on startup.
+;  #f -> records of this type do not survive a dump/resume; in images they
+;        are replaced by their first slot (so we make sure they have one)
+;  a one-argument procedure -> pass the record to this procedure
+;
+; Resumers are primarily intended for use by external code which keeps
+; fields in records which do not survive a dump under their own power.
+; For example, a record may contain a reference to a OS-dependent value.
+;
+; Resumers are called by the VM on startup.
+
+(define (define-record-resumer rt resumer)
+  (if (and (record-type? rt)
+	   (or (eq? #t resumer)
+	       (and (eq? #f resumer)
+		    (< 0 (record-type-number-of-fields rt)))
+	       (procedure? resumer)))
+      (set-record-type-resumer! rt resumer)
+      (call-error "invalid argument" define-record-resumer rt resumer)))
+
+; By default we leave records alone.
+
+(define default-record-resumer
+  #t)
+
+(define (initialize-records! resumer-records)
+  (if (vector? resumer-records)
+      (do ((i 0 (+ i 1)))
+	  ((= i (vector-length resumer-records)))
+	(resume-record (vector-ref resumer-records i)))))
+
+(define (resume-record record)
+  ((record-type-resumer (record-type record))
+     record))
+
+;----------------
+; Initializing *RECORD-TYPE* and making a type.
+
+(set! *record-type*
+      (make-record-type 'record-type record-type-fields))
+
+(record-set! *record-type* 0 *record-type*)
+
+(define :record-type *record-type*)
+
+(define-record-discloser :record-type
+  (lambda (rt)
+    (list 'record-type
+	  (record-type-uid rt)
+	  (record-type-name rt))))
+
diff --git a/scheme/rts/root-scheduler.scm b/scheme/rts/root-scheduler.scm
new file mode 100644
index 0000000..0bb8685
--- /dev/null
+++ b/scheme/rts/root-scheduler.scm
@@ -0,0 +1,147 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; The root scheduler.
+;
+; This uses RUN-THREADS-WITH-HOUSEKEEPER from the round-robin scheduler.
+; The housekeeping thread flushes output buffers and wakes any sleeping
+; threads whose time has come.
+
+(define (root-scheduler thunk quantum housekeeping-quantum)
+  (let ((*result* 111))
+    (call-with-current-continuation
+      (lambda (abort)
+	(initialize-channel-i/o!)
+	(run-threads-with-housekeeper (make-root-event-handler
+				         (lambda () (set! *result* (thunk)))
+					 quantum
+					 abort)
+				      (lambda ()
+					(spawn-output-forcers #t)
+					(wake-some-threads))
+				      housekeeping-quantum)
+	*result*))))
+
+; Returns a handler and a procedure for adding new threads.  No events
+; are handled specially.  The only upcall is for aborting execution.
+
+(define (make-root-event-handler thunk quantum abort)
+  (let ((runnable (make-thread-queue))
+	(thread-count (make-counter))
+	(safe-dynamic-env (with-handler root-handler get-dynamic-env))
+	(thread (make-thread thunk
+			     (get-dynamic-env)
+			     'scheduler-initial-thread)))
+    (increment-counter! thread-count)
+    (enqueue-thread! runnable thread)
+    (round-robin-event-handler
+       runnable quantum safe-dynamic-env thread-count
+       (lambda args #f)			; we handle no events
+       (lambda (thread token args)	; upcall handler
+	 (if (eq? token abort-token)
+	     (abort (car args))
+	     (propogate-upcall thread token args)))
+       root-wait)))
+
+; Let the user know if anything goes wrong while running a root thread.
+; Errors kill the offending thread, warnings allow it to proceed.
+
+(define (root-handler condition next-handler)
+  (let ((out (current-error-port)))
+    (cond ((error? condition)
+	   (display "Error while running root thread, thread killed: " out)
+	   (display (current-thread) out)
+	   (newline out)
+	   (cheap-display-condition condition out)
+	   (terminate-current-thread))
+	  ((warning? condition)
+	   (cheap-display-condition condition out)
+	   (unspecific))     ;proceed
+	  (else
+	   (next-handler)))))
+
+(define (cheap-display-condition condition out)
+  (display (case (car condition)
+	     ((error) "Error")
+	     ((exception) "Exception")
+	     ((warning) "Warning")
+	     (else (car condition)))
+	   out)
+  (display ": " out)
+  (display (cadr condition) out)
+  (newline out)
+  (for-each (lambda (irritant)
+	      (display "    " out)
+	      (display irritant out)
+	      (newline out))
+	    (cddr condition)))
+	 
+; Upcall token
+
+(define abort-token (list 'abort-token))
+
+(define scheme-exit-now
+   (lambda (status)
+      (upcall abort-token status)))
+
+; Getting around to calling the VM's WAIT procedure.  We disable interrupts
+; to keep things from happening behind our back, and then see if there is
+; any thread to run or any event pending, or if work may appear in the future.
+
+(define (root-wait)
+  (set-enabled-interrupts! 0)
+  (let ((forcers? (spawn-output-forcers #f)))
+    (call-with-values
+     wake-some-threads
+     (lambda (woke-some? time-until-wakeup)
+       (cond ((or forcers? woke-some? (event-pending?))
+	      (set-enabled-interrupts! all-interrupts)
+	      #t)
+	     ((or time-until-wakeup
+		  (waiting-for-i/o?))
+	      (do-some-waiting time-until-wakeup)
+	      (set-enabled-interrupts! all-interrupts)
+	      (root-wait))
+	     ((session-data-ref deadlock-handler)
+	      => (lambda (handler)
+		   (handler)
+		   (set-enabled-interrupts! all-interrupts)
+		   #t))
+	     (else
+	      (set-enabled-interrupts! all-interrupts)
+	      #f))))))
+
+(define one-day-of-milliseconds (* (* 1000 60) (* 60 24)))
+
+; A mess because a fixnum's worth of milliseconds is only a few days.
+; The VM's WAIT procedure takes its maximum-wait argument in either
+; milliseconds or minutes.
+
+(define (do-some-waiting time-until-wakeup)
+  (call-with-values
+   (lambda ()
+     (cond ((not time-until-wakeup)
+	    (values -1 #f))
+	   ((< time-until-wakeup one-day-of-milliseconds)
+	    (values time-until-wakeup #f))
+	   (else
+	    (values (quotient time-until-wakeup 60000)
+		    #t))))
+   (structure-ref primitives wait)))
+
+(define deadlock-handler (make-session-data-slot! #f))
+
+(define (call-when-deadlocked! thunk)
+  (session-data-set! deadlock-handler thunk))
+
+; Find any ports that need to be flushed.  We get both a thunk to flush the
+; port and the port itself; the port is only used for reporting problems.
+
+(define (spawn-output-forcers others-waiting?)
+  (let ((thunks (output-port-forcers others-waiting?)))
+    (cond ((null? thunks)
+	   #f)
+	  (else
+	   (for-each spawn-on-root thunks)
+	   #t))))
+	 
+(define unspecific (structure-ref primitives unspecific))
diff --git a/scheme/rts/scheduler.scm b/scheme/rts/scheduler.scm
new file mode 100644
index 0000000..0eabbb6
--- /dev/null
+++ b/scheme/rts/scheduler.scm
@@ -0,0 +1,140 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; A parameterized scheduler.
+
+; (run-threads event-handler) -> unspecific
+;   (event-handler thread time-left event event-data) -> [thread args time]
+; A bogus BLOCKED event is passed to the handler to get the initial thread.
+
+(define (run-threads event-handler)
+  (call-with-values
+   (lambda ()
+     (event-handler #f 0 (enum event-type blocked) '()))
+   (lambda (thread time)
+     (if thread
+	 (let loop ((thread thread) (time time))
+	   (call-with-values
+	    (lambda ()
+	      (run thread time))
+	    (lambda (time-left event . event-data)
+	      (call-with-values
+	       (lambda ()
+		 (event-handler thread time-left event event-data))
+	       (lambda (thread time)
+		 (if thread
+		     (loop thread time)))))))))))
+	    
+; Same thing, with the addition of a housekeeping thunk that gets
+; run periodically.
+
+(define (run-threads-with-housekeeper event-handler housekeeper delay)
+  (call-with-values
+   (lambda ()
+     (event-handler #f 0 (enum event-type blocked) '()))
+   (lambda (thread time)
+     (if thread
+	 (let loop ((thread thread) (time time) (hk-time delay))
+	   (call-with-values
+	    (lambda ()
+	      (run thread time))
+	    (lambda (time-left event . event-data)
+	      (let ((hk-time (let ((temp (- hk-time (- time time-left))))
+			       (if (<= temp 0)
+				   (begin
+				     (housekeeper)
+				     delay)
+				   temp))))
+		(call-with-values
+		 (lambda ()
+		   (event-handler thread time-left event event-data))
+		 (lambda (thread time)
+		   (if thread
+		       (loop thread time hk-time))))))))))))
+
+; An event-handler that does round-robin scheduling.
+; Arguments:
+;    runnable         ; queue of threads
+;    quantum          ; number of ticks each thread gets
+;    dynamic-env      ; initial dynamic environments for new threads
+;    thread-count     ; counter tracking the number of threads
+;    event-handler : event-type event-data -> handled?
+;    upcall-handler : thread token . args -> return-values
+;    wait             ; thunk returns #t if scheduling is to continue
+
+(define (round-robin-event-handler runnable quantum dynamic-env thread-count
+				   event-handler upcall-handler wait)
+
+  (define (thread-event-handler thread time-left event event-data)
+    (enum-case event-type event
+
+      ;; the thread stops, either temporarily or permanently
+      ((blocked)
+       (next-thread))
+      ((completed killed)
+       (decrement-counter! thread-count)
+       (next-thread))
+      ((out-of-time)
+       (enqueue-thread! runnable thread)
+       (next-thread))
+
+      ;; the thread keeps running
+      ((upcall)
+       (call-with-values
+	(lambda ()
+	  (apply upcall-handler event-data))
+	(lambda results
+	  (set-thread-arguments! thread results)
+	  (values thread time-left))))
+      (else
+       (asynchronous-event-handler event event-data)
+       (values thread time-left))))
+
+  ;; We call EVENT-HANDLER first so that it can override the default behavior
+  (define (asynchronous-event-handler event event-data)
+    (or (event-handler event event-data)
+	(enum-case event-type event
+	  ((runnable)
+	   (enqueue-thread! runnable (car event-data)))
+	  ((spawned)
+	   (increment-counter! thread-count)
+	   (enqueue-thread! runnable
+			    (make-thread (car event-data)
+					 dynamic-env
+					 (cadr event-data))))
+	  ((no-event)
+	   (values))
+	  (else
+	   (error "unhandled event"
+		  (cons (enumerand->name event event-type)
+			event-data)
+		  event-handler)))))
+
+  (define (next-thread)
+    (if (thread-queue-empty? runnable)
+	(call-with-values
+	 get-next-event!
+	 (lambda (event . data)
+	   (cond ((not (eq? event (enum event-type no-event)))
+		  (asynchronous-event-handler event data)
+		  (next-thread))
+		 ((wait)
+		  (next-thread))
+		 (else
+		  (values #f 0)))))   ; scheduler quits
+	(values (dequeue-thread! runnable)
+		quantum)))
+
+  thread-event-handler)
+
+; Simple counting cell
+
+(define (make-counter)
+  (list 0))
+
+(define counter-value car)
+
+(define (increment-counter! count)
+  (set-car! count (+ 1 (car count))))
+
+(define (decrement-counter! count)
+  (set-car! count (- (car count) 1)))
diff --git a/scheme/rts/session.scm b/scheme/rts/session.scm
new file mode 100644
index 0000000..fb2d84e
--- /dev/null
+++ b/scheme/rts/session.scm
@@ -0,0 +1,25 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+; Session data
+
+; The initializers are saved in images.
+
+(define *session-data-initializers* '())
+
+(define (make-session-data-slot! init)
+  (let ((slot (length *session-data-initializers*)))
+    (set! *session-data-initializers* (cons init *session-data-initializers*))
+    (if (vector? (session-data))
+	(set-session-data! (list->vector
+			    (reverse
+			     (cons init
+				   (reverse (vector->list (session-data))))))))
+    slot))
+
+(define (session-data-ref slot)
+  (vector-ref (session-data) slot))
+
+(define (session-data-set! slot value)
+  (vector-set! (session-data) slot value))
+
+(define (initialize-session-data!)
+  (set-session-data! (list->vector (reverse *session-data-initializers*))))
diff --git a/scheme/rts/signal.scm b/scheme/rts/signal.scm
new file mode 100644
index 0000000..8503844
--- /dev/null
+++ b/scheme/rts/signal.scm
@@ -0,0 +1,35 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+;;;; Signalling conditions
+
+; I don't like the term "signal," but that's the one Gnu Emacs Lisp,
+; Common Lisp, and Dylan use, so it's probably best to stick with it.
+
+
+(define make-condition cons)
+
+(define (signal type . stuff)
+  (signal-condition (make-condition type stuff)))
+
+; Warn
+
+(define (warn message . irritants)
+  (signal-condition (make-condition 'warning (cons message irritants))))
+
+
+; Syntax errors
+
+(define (syntax-error . rest)  ; Must return a valid expression.
+  (signal-condition (make-condition 'syntax-error rest))
+  ''syntax-error)
+
+
+; "Call error" - this means that the condition's "stuff" (cdr) is of
+; the form (message procedure . args), and should be displayed appropriately.
+; Proceeding from such an error should return the value that the call
+; to the procedure on the args should have returned.
+
+(define (call-error message proc . args)
+  (signal-condition (make-condition 'call-error
+				    (cons message (cons proc args)))))
diff --git a/scheme/rts/sleep.scm b/scheme/rts/sleep.scm
new file mode 100644
index 0000000..6c6e29e
--- /dev/null
+++ b/scheme/rts/sleep.scm
@@ -0,0 +1,45 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Sleeping for N milliseconds.
+
+(define (sleep n)
+  (let ((queue (make-thread-queue)))  ; only one entry, but it must be a queue
+    (disable-interrupts!)
+    (enqueue-thread! queue (current-thread))
+    (set! *dozers*
+	  (insert (cons (+ (real-time) n) queue)
+		  *dozers*
+		  (lambda (frob1 frob2)
+		    (< (car frob1) (car frob2)))))
+    (block)))
+
+(define *dozers* '())  ; List of (wakeup-time . queue)
+	  
+(define (insert x l <)
+  (cond ((null? l) (list x))
+	((< x (car l)) (cons x l))
+	(else (cons (car l) (insert x (cdr l) <)))))
+
+; Called by root scheduler, so won't be interrupted.
+; This returns two values, a boolean that indicates if any threads were
+; woken and the time until the next sleeper wakes.  We have to check for
+; threads that have been started for some other reason.
+
+(define (wake-some-threads)
+  (if (null? *dozers*)
+      (values #f #f)
+      (let ((time (real-time)))
+	(let loop ((dozers *dozers*) (woke? #f))
+	  (if (null? dozers)
+	      (begin
+		(set! *dozers* '())
+		(values woke? #f))
+	      (let ((next (car dozers)))
+		(cond ((thread-queue-empty? (cdr next))
+		       (loop (cdr dozers) woke?))
+		      ((< time (car next))
+		       (set! *dozers* dozers)
+		       (values woke? (- (car next) time)))
+		      (else
+		       (make-ready (dequeue-thread! (cdr next)))
+		       (loop (cdr dozers) #t)))))))))
diff --git a/scheme/rts/template.scm b/scheme/rts/template.scm
new file mode 100644
index 0000000..b644105
--- /dev/null
+++ b/scheme/rts/template.scm
@@ -0,0 +1,27 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Somewhat redundant with vm/istruct.scm.  Fix this some day.
+
+; Templates
+;  Templates are made only by the compiler.
+
+;(define make-template make-vector)
+
+;(define (template? obj)
+;  (and (vector? obj)
+;       (>= (vector-length obj) template-overhead)
+;       (code-vector? (template-code obj))
+;       ))
+
+;(define template-length vector-length)
+;(define template-ref vector-ref)
+;(define template-set! vector-set!)
+
+(define template-overhead 2)
+
+(define (template-code tem) (template-ref tem 0))
+(define (template-info tem) (template-ref tem 1))
+(define (set-template-code! tem cv)   (template-set! tem 0 cv))
+(define (set-template-info! tem info) (template-set! tem 1 info))
+
diff --git a/scheme/rts/thread.scm b/scheme/rts/thread.scm
new file mode 100644
index 0000000..a833a43
--- /dev/null
+++ b/scheme/rts/thread.scm
@@ -0,0 +1,671 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Threads.
+
+; This is inspired by Haynes et al's  engines.
+;
+; The fundamental operation is (RUN <thread> <time>), which runs the thread
+; for the given amount of time.
+;
+; Each thread has:
+;   saved continuation
+;   saved interrupt mask
+;   scheduler, which is the thread that RUNs this one
+;   remaining time in clock ticks ('waiting = waiting for events)
+;   queue that is holding this thread, if any
+;   arguments waiting to be passed to the thread when it is next run
+;   dynamic environment
+;   dynamic point
+;   whatever data the scheduler wants
+; Schedulers also have:
+;   list of pending events
+;   thread that this scheduler is currently running
+;
+; A `scheduler' is any thread that has called RUN.  All threads are organized
+; into a tree by the THREAD-SCHEDULER field, with the pointers pointing from
+; the leaves to the root.
+;
+; There is a doubly linked list of running threads linked by the
+; the thread-scheduler and thread-current-task fields.
+;   e1 <-> e2 <-> ... <-> eN-1 <-> eN
+; e1 is the top thread and eN is the thread whose code is actually running.
+; All except eN are in the middle of a call to RUN.  The scheduler pointers
+; point to the left and the current-task pointers point to the right.
+;
+; When an thread stops, its scheduler is run and the portion of the list from
+; the stopped thread down is saved for when the stopped thread is resumed.  For
+; example, suppose e3 runs out of time.  Then the list is shortened to
+; e1 <-> e2 and the e3 <-...-> eN portion is saved.  When e3 is resumed,
+; the list is spliced back together and eN's continuation is resumed.
+
+(define-record-type thread :thread
+  (really-make-thread dynamic-env dynamic-point continuation scheduler
+		      queue arguments
+		      events current-task uid name)
+  thread?
+  (dynamic-env    thread-dynamic-env)   ;Must be first!  (See fluid.scm)
+  (dynamic-point  thread-dynamic-point set-thread-dynamic-point!)
+  					;Must be second!  (See fluid.scm)
+  (continuation   thread-continuation set-thread-continuation!)
+  (queue          thread-queue set-thread-queue!)
+  (arguments      thread-arguments set-thread-arguments!)
+  (time           thread-time set-thread-time!)
+  (scheduler      thread-scheduler set-thread-scheduler!)
+  (data           thread-data set-thread-data!)
+  (events         thread-events set-thread-events!)             ; schedulers
+  (current-task   thread-current-task set-thread-current-task!) ; schedulers
+  (uid            thread-uid)       ; for debugging (and as a cheap weak pointer)
+  (name		  thread-name))     ; for debugging
+
+(define-record-discloser :thread
+  (lambda (thread)
+    (cons 'thread
+	  (cons (thread-uid thread)
+		(let ((name (thread-name thread)))
+		  (if name
+		      (list name)
+		      '()))))))
+
+(define *thread-uid* 0)
+
+(define (make-thread thunk dynamic-env name)
+  (let ((thread (really-make-thread dynamic-env
+				    #f               ; dynamic-point root
+				    (thunk->continuation
+				     (thread-top-level thunk))
+				    (current-thread) ; scheduler
+				    #f               ; queue
+				    '()              ; arguments
+				    #f               ; events
+				    #f               ; current-task
+				    *thread-uid*
+				    name)))
+    (set! *thread-uid* (+ *thread-uid* 1))
+    thread))
+
+;----------------
+; Call THUNK and then suspend.  The LET is just to give the thunk a name
+; in the debugger.  This thunk shows up at the bottom of every ,preview.
+
+(define (thread-top-level thunk)
+  (let ((thread-start (lambda ()
+			(call-with-values
+			  thunk
+			  (lambda values
+			    (suspend (enum event-type completed) values))))))
+    thread-start))
+
+; Find the thread with the indicated uid.  This is expensive.  It is used
+; by rts/channel-port.scm to when forcibly unlocking one of the REPL's ports.
+
+(define (thread-uid->thread uid)
+  (let ((threads (all-threads)))
+    (let loop ((i 0))
+      (cond ((= i (vector-length threads))
+	     #f)
+	    ((= uid (thread-uid (vector-ref threads i)))
+	     (vector-ref threads i))
+	    (else
+	     (loop (+ i 1)))))))
+
+(define (all-threads)
+  ((structure-ref primitives find-all-records) :thread))
+
+; Add EVENT to THREAD's event queue.
+; Called with interrupts disabled.
+
+(define (add-event! thread event)
+  (enqueue! (or (thread-events thread)
+		(let ((q (make-queue)))
+		  (set-thread-events! thread q)
+		  q))
+	    event))
+
+; A bit of magic courtesy of JAR.  We need to use PRIMITIVE-CWCC to save
+; thread continuations because CALL-WITH-CURRENT-CONTINUATION saves the
+; dynamic state, including the current thread.  PRIMITIVE-CWCC's continuations
+; are not procedures, so we need this thing to convert a thread's initial
+; thunk into a continuation.
+
+; (Alternatively, we could make a version of CWCC that didn't save the
+; dynamic state.  That would slow down context switching, which is
+; presumably more frequent than thread creation.)
+
+(define (thunk->continuation thunk)
+  (compose-continuation thunk #f))
+
+; Return a continuation that will call PROC with continuation CONT.
+; Synopsis: we grab the current continuation, install the continuation
+; we want to create, and then at the last minute save the new continuation
+; and return it to the one we grabbed on entry.
+
+(define (compose-continuation proc cont)
+  (primitive-cwcc                ; grab the current continuation so that
+   (lambda (k)                   ;    we can return
+     (with-continuation          ; install CONT or an empty continuation
+      (or cont (loophole :escape #f))
+      (lambda ()
+        (call-with-values        ; install PROC as a continuation
+         (lambda ()
+           (primitive-cwcc       ; grab a continuation that will call PROC and
+            (lambda (k2)         ;    then return to the installed continuation
+              (with-continuation ; return the PROC-calling continuation to
+               k                 ;    the continuation we grabbed on entry
+               (lambda () k2)))))
+	 proc))))))
+      
+;----------------
+; Enqueueing and dequeuing threads.
+
+; Rename the queue operations as thread-specific ones (both for clarity
+; and because we will want to use priority queues in the future).
+
+(define make-thread-queue make-queue)
+(define thread-queue-empty? queue-empty?)
+
+(define (enqueue-thread! queue thread)
+  (if (thread-queue thread)
+      (error "enqueued thread being added to another queue" thread queue))
+  (set-thread-queue! thread queue)
+  (enqueue! queue thread))
+
+(define (dequeue-thread! queue)
+  (let ((thread (dequeue! queue)))
+    (set-thread-queue! thread #f)
+    thread))
+
+(define (remove-thread-from-queue! thread)
+  (if (thread-queue thread)
+      (begin
+	(delete-from-queue! (thread-queue thread) thread)
+	(set-thread-queue! thread #f))))
+
+;----------------
+
+(define current-thread (structure-ref primitives current-thread))
+(define set-current-thread! (structure-ref primitives set-current-thread!))
+
+; Return values for RUN.
+
+(define-enumeration event-type
+  ;; Reason        Additional return values
+  (
+  ;; events relating to the running thread
+   out-of-time
+   completed      ; . <results>       
+   blocked
+   killed 
+   upcall         ; <args>              unknown upcalls are passed up
+
+  ;; asynchronous events
+   runnable       ; <thread> <args>     <thread> is now runnable
+   spawned        ; <thunk> <id> ...    spawn <thunk> as a new thread
+   interrupt      ; <type> . <stuff>    an interrupt has occured
+   deadlock       ;                     no one can run
+ 
+   no-event       ;                     there are no pending events
+   ))
+
+; DEADLOCK is used by the REPL to gain control when the thread system deadlocks.
+
+; (RUN <thread> <time>) -> <time-left> <event-type> . <stuff>
+;
+; Run <thread> for no more than <time>.  The call returns when the thread
+; stops, returning the remaining time, the reason the thread stopped, and
+; any addition information relating to the reason.  Times are in milliseconds.
+;
+; What this does:
+; 1. Check that THREAD is runnable, that it belongs to the current thread,
+;    and that it can accept any values being returned.
+; 2. Return immediately if an event is pending.
+; 3. Otherwise suspend the current thread, make THREAD its task, and then
+;    run THREAD (or the thread that it is running or ...)
+
+(define (run thread time)
+  (disable-interrupts!)
+  (let ((scheduler (current-thread)))
+    (cond ((not (thread-continuation thread))
+	   (enable-interrupts!)
+	   (error "RUN called with a completed thread" thread))
+	  ((not (eq? (thread-scheduler thread) scheduler))
+	   (enable-interrupts!)
+	   (error "thread run by wrong scheduler" thread scheduler))
+	  ((thread-queue thread)
+	   (enable-interrupts!)
+	   (error "thread run while still on a queue" thread))
+	  ((and (thread-current-task thread)
+		(not (null? (thread-arguments thread))))
+	   (enable-interrupts!)
+	   (error "returning values to running thread"
+		  thread
+		  (thread-arguments thread)))
+	  ((event-pending?)
+	   (enable-interrupts!)
+	   (apply values time (dequeue! (thread-events (current-thread)))))
+	  (else
+	   (set-thread-current-task! scheduler thread)
+	   (find-and-run-next-thread thread time)))))
+
+; The next thread to run is the scheduler of the highest thread in the chain
+; with no time left or, if there is no such thread, the bottom thread in the
+; chain.  The time limit is the minimum of the remaining times of threads
+; above the thread to be run.
+;
+; We first go down from the user-provided thread, looking for a thread with
+; no time left.  We then continue either with that thread's scheduler or with
+; the bottom thread of the chain.
+
+; This could be modified to add the current time to NEW-THREAD and any threads
+; below.  Then the old time limit could be reused if none of the new threads
+; got less time than SCHEDULER and above.  This is slower and simpler.
+
+(define (find-and-run-next-thread new-thread time)
+  (set-thread-time! new-thread time) ; in case we don't run it now
+  (let loop ((thread new-thread) (time time))
+    (let ((next (thread-current-task thread)))
+      (if (and next
+	       (< 0 (thread-time next)))
+	  (loop next (min time (thread-time next)))
+	  (debit-thread-times-and-run! thread time)))))
+
+; Debit the times of all threads from the current-thread on up.  If we find a
+; thread with no time left, then that thread's scheduler becomes the potential
+; next thread.
+;
+; Only the root thread can end up with a time-limit of #f, as all other threads
+; have schedulers.
+
+(define (debit-thread-times-and-run! next-to-run time-limit)
+  (let ((elapsed (interrupt-timer-time)))
+    (let loop ((thread (current-thread))
+	       (time-limit time-limit)
+	       (next-to-run next-to-run))
+      (let ((scheduler (thread-scheduler thread)))
+	(cond (scheduler
+	       (let ((time-left (- (thread-time thread) elapsed)))
+		 (set-thread-time! thread time-left)
+		 (if (<= time-left 0)
+		     (loop scheduler #f scheduler)
+		     (loop scheduler
+			   (if time-limit
+			       (min time-limit time-left)
+			       time-left)
+			   next-to-run))))
+	      (next-to-run
+	       (run-next-thread next-to-run time-limit))
+	      (else
+	       (schedule-interrupt! time-limit)))))))
+
+; Debit the times of all running threads and run whomever is next.
+
+(define (handle-timer-interrupt interrupted-template ei)
+  (if (thread-scheduler (current-thread))
+      (debit-thread-times-and-run! #f #f)))
+
+; Run the next thread, first scheduling an interrupt if the thread is not the
+; root thread.  If the next thread has a current task, then the return values
+; are the normal out-of-time values. The bottom thread of the chain gets
+; whatever return values have been stashed earlier.
+
+(define (run-next-thread thread time-limit)
+  (if time-limit (schedule-interrupt! time-limit))
+  (let ((arguments (if (thread-current-task thread)
+		       (list 0 (enum event-type out-of-time))
+		       (thread-arguments thread))))
+    (set-thread-arguments! thread '())
+    (switch-to-thread thread arguments)))
+
+; Fast binary version of MIN
+
+(define (min x y)
+  (if (< x y) x y))
+    
+;----------------
+; Save the current thread and start running NEW-THREAD.
+
+(define (switch-to-thread thread return-values)
+  (primitive-cwcc
+   (lambda (cont)
+     (set-thread-continuation! (current-thread) cont)
+     (run-thread thread return-values))))
+
+; Start running THREAD.  This assumes that THREAD has already been linked into
+; the list of running threads.
+
+(define (run-thread thread return-values)
+  (set-current-thread! thread)
+  (set-thread-current-task! thread #f)
+  (with-continuation (thread-continuation thread)
+    (lambda ()
+      (set-thread-continuation! thread #f)	; HCC: for GC
+      (enable-interrupts!)
+      (apply values return-values))))
+
+;----------------
+; (SUSPEND <reason> <stuff>) stops the current thread and returns from
+; the call to RUN that invoked it.  The arguments passed to SUSPEND become
+; the return values of the call to RUN.  SUSPEND itself returns the arguments
+; passed to RUN when the stopped thread is restarted.
+
+(define (suspend reason stuff)
+  (disable-interrupts!)
+  (suspend-to (thread-scheduler (current-thread))
+	      (cons reason stuff)))
+
+; Stop running the current thread and return from the RUN call in
+; SCHEDULER with the given reason.  We need to debit the time of every
+; thread between the current one and SCHEDULER.
+
+(define (suspend-to scheduler event)  ; called with interrupts disabled
+  (debit-down! (thread-current-task scheduler))
+  (switch-to-thread scheduler
+		    (cons (thread-time (thread-current-task scheduler))
+			  event)))
+
+(define (debit-down! thread)  
+  (let ((elapsed (interrupt-timer-time)))
+    (let loop ((thread thread))
+      (if thread
+          (begin
+            (set-thread-time! thread (- (thread-time thread) elapsed))
+            (loop (thread-current-task thread)))))))
+
+; Same thing, except that we don't save the current continuation and
+; we don't need to debit the thread's time.  This is used for completed
+; and killed threads and is not exported.
+
+(define (exit reason stuff)
+  (disable-interrupts!)
+  (let ((thread (current-thread)))
+    (set-thread-continuation! thread #f)
+    (run-thread (thread-scheduler thread)
+		(cons (- (thread-time thread)
+			 (interrupt-timer-time))
+		      (cons reason stuff)))))
+
+; Wait for something to happen.  If an event is pending we return immediately.
+; Another same thing, except that we have to be careful because we need to
+; set the current thread's time field to a non-integer.
+
+(define (wait)
+  (let ((interrupts (set-enabled-interrupts! no-interrupts)))
+    (let ((thread (current-thread)))
+      (if (not (and (thread-events thread)
+		    (not (queue-empty? (thread-events thread)))))
+	  (let ((time-left (- (thread-time thread)
+			      (interrupt-timer-time))))
+	    (set-thread-time! thread 'waiting)
+	    (switch-to-thread (thread-scheduler thread)
+			      (list time-left (enum event-type blocked)))))
+      (set-enabled-interrupts! interrupts))))
+
+; Is THREAD waiting for something to happen.
+
+(define (waiting? thread)
+  (eq? (thread-time thread) 'waiting))
+
+; Various calls to SUSPEND.
+
+(define (block)
+  (suspend (enum event-type blocked) '()))
+
+(define (relinquish-timeslice)
+  (suspend (enum event-type out-of-time) '()))
+
+; Send the upcall to the current scheduler and check the return value(s)
+; to see if it was handled properly.
+
+(define (upcall token . args)
+  (propogate-upcall (current-thread) token args))
+
+; Send the upcall to the current thread's handler, if it has one.
+
+(define (propogate-upcall thread token args)
+  (if (thread-scheduler (current-thread))
+      (suspend (enum event-type upcall) (list thread token args))
+      (begin
+	(interrupt-thread thread
+			  (lambda ()
+			    (apply error "unhandled upcall" token args)))
+	(values))))
+
+(define (kill-thread! thread)   ; dangerous!
+  (interrupt-thread thread
+		    (lambda ignored
+		      (exit (enum event-type killed) '()))))
+
+;----------------
+; Make THREAD execute PROC the next time it is run.  The thread's own
+; continuation is passed whatever PROC returns.
+
+(define (interrupt-thread thread proc)
+  (let ((interrupts (set-enabled-interrupts! no-interrupts)))
+    (cond ((and (thread? thread)
+		(not (running? thread)))
+	   (set-thread-continuation!
+	    thread
+	    (compose-continuation proc (thread-continuation thread)))
+	   (set-enabled-interrupts! interrupts))
+	  (else
+	   (set-enabled-interrupts! interrupts)
+	   (call-error "invalid argument" interrupt-thread thread)))))
+  
+;----------------
+; Dealing with event queues
+
+; Returns the next event scheduled for the current thread.
+
+(define (get-next-event!)
+  (let* ((interrupts (disable-interrupts!))
+	 (events (thread-events (current-thread))))
+    (if (or (not events)
+	    (queue-empty? events))
+	(begin
+	  (set-enabled-interrupts! interrupts)
+	  (enum event-type no-event))
+	(let ((event (dequeue! events)))
+	  (set-enabled-interrupts! interrupts)
+	  (apply values event)))))
+
+(define (event-pending?)
+  (let ((events (thread-events (current-thread))))
+    (and events (not (queue-empty? events)))))
+
+; Schedule the given event for THREAD.  If THREAD is waiting, a RUNNABLE
+; event is also scheduled for its scheduler and so on up the tree.  If
+; THREAD is running we suspend to allow the interrupt to be processed
+; immediately (running threads that are not the current thread must be
+; above the current thread in the tree and so have priority over it).
+
+(define (schedule-event thread . event)
+  (let ((interrupts (disable-interrupts!)))
+    (cond ((eq? thread (current-thread))
+	   (add-event! thread event)
+	   (values))
+	  ((waiting? thread)
+	   (add-event! thread event)
+	   (schedule-wakeup thread))
+	  ((running? thread)
+	   (suspend-to thread event))
+	  ((thread-current-task thread)
+	   (set-thread-arguments! thread
+				  (cons (thread-time (thread-current-task thread))
+					event))
+	   (set-thread-current-task! thread #f))
+	  (else
+	   (add-event! thread event)))
+    (set-enabled-interrupts! interrupts)
+    ((structure-ref primitives unspecific))))
+
+; Make THREAD's scheduler aware of the fact that THREAD is runnable, and
+; similarly for its own scheduler and so on up the tree.
+; Called with interrupts disabled.
+
+(define (schedule-wakeup thread)
+  (set-thread-time! thread 0)             ; clear WAITING flag
+  (let ((scheduler (thread-scheduler thread)))
+    (if scheduler
+	(let ((event (list (enum event-type runnable) thread)))
+	  (cond ((eq? scheduler (current-thread))
+		 (add-event! scheduler event)
+		 (values))
+		((waiting? scheduler)
+		 (add-event! scheduler event)
+		 (schedule-wakeup scheduler))
+		((running? scheduler)
+		 (suspend-to scheduler event)))))))
+
+; Debugging routine
+
+(define (show-running)
+  (apply debug-message "Running:" (do ((e (current-thread) (thread-scheduler e))
+				       (l '() (cons (thread-name e)
+						    (cons " " l))))
+				      ((not e)
+				       (reverse l)))))
+
+; Walk up the scheduler pointers from the current thread to see if THREAD is
+; running.
+
+(define (running? thread)
+  (let loop ((running (current-thread)))
+    (cond ((not running)
+	   #f)
+	  ((eq? running thread)
+	   #t)
+	  (else
+	   (loop (thread-scheduler running))))))
+
+; Spawn a new thread either on the current thread's scheduler or on a specific
+; scheduler.
+
+(define (spawn thunk . id)
+  (apply spawn-on-scheduler (thread-scheduler (current-thread)) thunk id))
+
+(define (spawn-on-root thunk . id)
+  (if (root-scheduler)
+      (apply spawn-on-scheduler
+	     (root-scheduler)
+	     thunk
+	     id)
+      (thunk)))
+
+(define (spawn-on-scheduler scheduler thunk . id)
+  (schedule-event scheduler
+		  (enum event-type spawned)
+		  thunk
+		  (if (null? id) #f (car id))))
+
+; Enqueue a RUNNABLE for THREAD's scheduler.
+
+(define (make-ready thread . args)
+  (if (thread-queue thread)
+      (error "trying to schedule a queued thread" thread))
+;  (if (not (null? (thread-arguments thread)))
+;      (error "trying to replace thread arguments"))
+  (set-thread-arguments! thread args)
+  (if (thread-scheduler thread)
+      (schedule-event (thread-scheduler thread)
+		      (enum event-type runnable)
+		      thread)
+      (error "MAKE-READY thread has no scheduler" thread)))
+
+;----------------
+
+(define (schedule-interrupt! time)
+  (schedule-interrupt time))
+
+(define (cancel-timer-interrupt!)
+  (schedule-interrupt 0))
+
+; Use CHEAP-TIME to save the cost of a system call on every context switch.
+; This clock is reset whenever we request an interrupt.
+
+(define (interrupt-timer-time)
+  ((structure-ref primitives time) (enum time-option cheap-time) #f))
+
+; Used for waking sleepers
+
+(define (real-time)
+  ((structure-ref primitives time) (enum time-option real-time) #f))
+
+; Install our own handler for timer interrupts and then start running threads.
+
+(define (with-threads thunk)
+  (with-interrupts-inhibited
+   (lambda ()
+     (dynamic-wind
+      (lambda ()
+	(set-interrupt-handler! (enum interrupt alarm)
+				handle-timer-interrupt))
+      (lambda ()
+	(start-multitasking thunk))
+      (lambda ()
+	(cancel-timer-interrupt!))))))
+
+; Add handler for deadlock and termination and morph ourselves into the
+; initial thread.
+
+(define (start-multitasking thunk)
+  (call-with-current-continuation
+    (lambda (exit-multitasking)
+      (with-handler
+       (lambda (c punt)
+	 (if (deadlock? c) (exit-multitasking 0) (punt)))
+       (lambda ()
+	 (call-with-current-continuation
+	   (lambda (terminate)
+	     (with-handler (lambda (c punt)
+			     (if (terminate? c) (terminate 0) (punt)))
+	       (lambda ()
+		 (set! *thread-uid* 0)
+		 (let ((thread (make-thread #f    ; thunk
+					    (get-dynamic-env)
+					    'initial-thread)))
+		   (set-thread-scheduler! thread #f)
+		   (set-thread-time! thread #f)
+		   (set-thread-dynamic-point! thread (get-dynamic-point))
+		   (set-current-thread! thread)
+		   (session-data-set! root-scheduler-slot thread))
+		 ;; End the LET to get THREAD out of the continuation to THUNK
+		 ;; Interrupts were turned off by START-THREADS
+		 (enable-interrupts!)
+		 ;; We throw out after THUNK to avoid teh EXIT below, as we
+		 ;; have no scheduler to exit to.
+		 (exit-multitasking (thunk))))))
+	 ;; land here when terminating a thread
+	 (exit (enum event-type completed) '()))))))
+
+; Raised when there is nothing to run.
+
+(define-condition-type 'deadlock '())
+(define deadlock? (condition-predicate 'deadlock))
+
+; Raised when the current thread has been killed.
+
+(define-condition-type 'terminate '())
+(define terminate? (condition-predicate 'terminate))
+
+; Kill the current thread.  DEBUG-MESSAGE is used to try and make sure that some
+; record exists when an error occured.  The system may be too broken for ERROR
+; to work properly.
+
+(define (terminate-current-thread)
+  (signal 'terminate)
+  (debug-message "Can't terminate current thread "
+		 (thread-uid (current-thread))
+		 " "
+		 (thread-name (current-thread)))
+  (error "can't terminate current thread")
+  0)    ; suppress bogus compiler warning
+
+
+;----------------
+; A slot in the session data to hold the root thread.
+
+(define root-scheduler-slot (make-session-data-slot! #f))
+
+(define (root-scheduler)
+  (session-data-ref root-scheduler-slot))
+
+
diff --git a/scheme/rts/time.scm b/scheme/rts/time.scm
new file mode 100644
index 0000000..d7f65a0
--- /dev/null
+++ b/scheme/rts/time.scm
@@ -0,0 +1,7 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+(define (real-time)
+  (time (enum time-option real-time) #f))
+
+(define (run-time)
+  (time (enum time-option run-time) #f))
diff --git a/scheme/rts/util.scm b/scheme/rts/util.scm
new file mode 100644
index 0000000..38b5c19
--- /dev/null
+++ b/scheme/rts/util.scm
@@ -0,0 +1,99 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This is file util.scm.
+
+;;;; Utilities
+
+(define (unspecific) (if #f #f))
+
+(define (reduce cons nil list)		;used by length, append, etc.
+  (if (null? list)
+      nil
+      (cons (car list) (reduce cons nil (cdr list)))))
+
+(define (filter pred lst)
+  (reduce (lambda (x rest)
+	    (if (pred x) (cons x rest) rest))
+	  '()
+	  lst))
+
+; Position of an object within a list
+
+(define (pos pred)
+  (lambda (thing l)
+    (let loop ((i 0) (l l))
+      (cond ((null? l) #f)
+	    ((pred thing (car l)) i)
+	    (else (loop (+ i 1) (cdr l)))))))
+
+(define posq (pos eq?))
+(define posv (pos eqv?))
+(define position (pos equal?))
+
+; Is pred true of any element of l?
+
+(define (any pred l)
+  ;; (reduce or #f l), sort of
+  (if (null? l)
+      #f
+      (or (pred (car l))
+	  (any pred (cdr l)))))
+
+; Is pred true of every element of l?
+
+(define (every pred l)
+  ;; (reduce and #t l), sort of
+  (if (null? l)
+      #t
+      (and (pred (car l)) (every pred (cdr l)))))
+
+(define (sublist l start end)
+  (if (> start 0)
+      (sublist (cdr l) (- start 1) (- end 1))
+      (let recur ((l l) (end end))
+	(if (= end 0)
+	    '()
+	    (cons (car l) (recur (cdr l) (- end 1)))))))
+
+(define (last x)
+  (if (null? (cdr x))
+      (car x)
+      (last (cdr x))))
+
+(define (insert x l <)
+  (cond ((null? l) (list x))
+        ((< x (car l)) (cons x l))
+        (else (cons (car l) (insert x (cdr l) <)))))
+
+;----------------
+; Variations on a theme.
+;
+; FOLD is a tail-recursive version of REDUCE.
+
+(define (fold folder list accumulator)
+  (do ((list list (cdr list))
+       (accum accumulator (folder (car list) accum)))
+      ((null? list)
+       accum)))
+
+(define (fold->2 folder list acc0 acc1)
+  (let loop ((list list) (acc0 acc0) (acc1 acc1))
+    (if (null? list)
+	(values acc0 acc1)
+	(call-with-values
+	 (lambda ()
+	   (folder (car list) acc0 acc1))
+	 (lambda (acc0 acc1)
+	   (loop (cdr list) acc0 acc1))))))
+
+(define (fold->3 folder list acc0 acc1 acc2)
+  (let loop ((list list) (acc0 acc0) (acc1 acc1) (acc2 acc2))
+    (if (null? list)
+	(values acc0 acc1 acc2)
+	(call-with-values
+	 (lambda ()
+	   (folder (car list) acc0 acc1 acc2))
+	 (lambda (acc0 acc1 acc2)
+	   (loop (cdr list) acc0 acc1 acc2))))))
diff --git a/scheme/rts/wind.scm b/scheme/rts/wind.scm
new file mode 100644
index 0000000..5d2acfb
--- /dev/null
+++ b/scheme/rts/wind.scm
@@ -0,0 +1,94 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This is file wind.scm.  (Rhymes with "find," not "pinned.")
+
+;;;; Dynamic-wind
+
+; This is a version of dynamic-wind that tries to do "the right thing"
+; in the presence of multiple threads of control.
+; This definition of "the right thing" is due to Pavel Curtis, and is
+; the one used in Scheme Xerox.  It is very different from what you will
+; find in, say, MIT Scheme.
+;
+; When we want to go to a new target state (e.g. on invoking a
+; continuation), we ascend to the nearest common ancestor of the
+; current state and the target state, executing the "out" (or
+; "unwind") thunk for each state on the way; then we climb back down
+; to the target state executing the "in" thunk for each state.  Unlike
+; the Hanson/Lamping algorithm, the tree of states is not altered in
+; any way.
+;
+; Each thread starts out in the root state, but continuations capture
+; the state where they're created.
+
+; Dynamic-wind
+
+(define (dynamic-wind in body out)
+  (in)
+  (let ((here (get-dynamic-point)))
+    (set-dynamic-point! (make-point (if here
+					(+ (point-depth here) 1)
+					1)
+				    in
+				    out
+				    (get-dynamic-env)
+				    here))
+    (let ((results (call-with-values body list)))
+      (set-dynamic-point! here)
+      (out)
+      (apply values results))))
+
+; call-with-current-continuation
+
+(define (call-with-current-continuation proc)
+  (primitive-cwcc
+    (lambda (cont)
+      (let ((env (get-dynamic-env))
+	    (point (get-dynamic-point)))
+	;; don't close over PROC
+	(proc (continuation->procedure cont env point))))))
+
+(define (continuation->procedure cont env point)
+  (lambda results
+    (travel-to-point! (get-dynamic-point) point)
+    (set-dynamic-env! env)
+    (set-dynamic-point! point)
+    (with-continuation cont
+      (lambda () (apply values results)))))
+
+; Point in state space = <depth, in, out, dynamic-env, parent>
+; dynamic-env = dynamic environment for execution of the in and out thunks
+
+(define-record-type point :point
+  (make-point depth in out dynamic-env parent)
+  (depth point-depth)
+  (in point-in)
+  (out point-out)
+  (dynamic-env point-dynamic-env)
+  (parent point-parent))
+
+; To make the modularity simpler, and to help Kali, the root point is #F.
+
+; Go to a point in state space.  This involves running out-thunks from
+; the current point out to its common ancestor with the target, and
+; then running in-thunks from the ancestor to the target.
+
+(define (travel-to-point! here target)
+  (cond ((eq? here target) 'done)
+	((or (not here)             ; HERE has reached the root.
+	     (and target
+		  (< (point-depth here)
+		     (point-depth target))))
+	 (travel-to-point! here (point-parent target))
+	 (set-dynamic-env! (point-dynamic-env target))
+	 (set-dynamic-point! target)
+	 ((point-in target)))
+	(else
+	 (set-dynamic-env! (point-dynamic-env here))
+	 (set-dynamic-point! here)
+	 ((point-out here))
+	 (travel-to-point! (point-parent here) target))))
+
+; (put 'let-dynamic-point 'scheme-indent-hook 1)
diff --git a/scheme/rts/write.scm b/scheme/rts/write.scm
new file mode 100644
index 0000000..108ae6e
--- /dev/null
+++ b/scheme/rts/write.scm
@@ -0,0 +1,154 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; This is file write.scm.
+
+;;;; WRITE
+
+; To use this with some Scheme other than Scheme 48, do the following:
+;  1. Copy the definition of output-port-option from port.scm
+;  2. Define write-string as appropriate (as a write-char loop)
+;  3. (define (disclose x) #f)
+
+(define (write obj . port-option)
+  (let ((port (output-port-option port-option)))
+    (let recur ((obj obj))
+      (recurring-write obj port recur))))
+
+(define (recurring-write obj port recur)
+  (cond ((null? obj) (write-string "()" port))
+        ((pair? obj) (write-list obj port recur))
+        ((eq? obj #t) (write-boolean 't port))
+        ((eq? obj #f) (write-boolean 'f port))
+        ((symbol? obj) (write-string (symbol->string obj) port))
+        ((number? obj) (write-number obj port))
+        ((string? obj) (write-string-literal obj port))
+        ((char? obj) (write-char-literal obj port))
+	(else (write-other obj port recur))))
+
+(define (write-boolean mumble port)
+  (write-char #\# port)
+  (write mumble port))
+
+(define (write-number n port)
+  (write-string (number->string n 10) port))
+
+(define (write-char-literal obj port)
+  (let ((probe (character-name obj)))
+    (write-string "#\\" port)
+    (if probe
+	(write probe port)
+	(write-char obj port))))
+
+(define (character-name char)
+  (cond ((char=? char #\space) 'space)
+        ((char=? char #\newline) 'newline)
+	(else #f)))
+
+(define (write-string-literal obj port)
+  (write-char #\" port)
+  (let ((len (string-length obj)))
+    (do ((i 0 (+ i 1)))
+	((= i len) (write-char #\" port))
+      (let ((c (string-ref obj i)))
+	(if (or (char=? c #\\) (char=? c #\"))
+	    (write-char #\\ port))
+	(write-char c port)))))
+
+(define (write-list obj port recur)
+  (cond ((quotation? obj)
+         (write-char #\' port)
+         (recur (cadr obj)))
+        (else
+         (write-char #\( port)
+         (recur (car obj))
+         (let loop ((l (cdr obj))
+                    (n 1))
+              (cond ((not (pair? l))
+                     (cond ((not (null? l))
+                            (write-string " . " port)
+                            (recur l))))
+                    (else
+                      (write-char #\space port)
+                      (recur (car l))
+                      (loop (cdr l) (+ n 1)))))
+         (write-char #\) port))))
+
+(define (quotation? obj)
+  (and (pair? obj)
+       (eq? (car obj) 'quote)
+       (pair? (cdr obj))
+       (null? (cddr obj))))
+
+(define (write-vector obj port recur)
+   (write-string "#(" port)
+   (let ((z (vector-length obj)))
+     (cond ((> z 0)
+            (recur (vector-ref obj 0))
+            (let loop ((i 1))
+              (cond ((>= i z))
+                    (else
+                     (write-char #\space port)
+                     (recur (vector-ref obj i))
+                     (loop (+ i 1))))))))
+   (write-char #\) port))
+
+; The vector case goes last just so that this version of WRITE can be
+; used in Scheme implementations in which records, ports, or
+; procedures are represented as vectors.  (Scheme 48 doesn't have this
+; property.)
+
+(define (write-other obj port recur)
+  (cond ((disclose obj)
+	 => (lambda (l)
+	      (write-string "#{" port)
+	      (display-type-name (car l) port)
+	      (for-each (lambda (x)
+			  (write-char #\space port)
+			  (recur x))
+			(cdr l))
+	      (write-string "}" port)))
+	((eof-object? obj) (write-string "#{End-of-file}" port))
+	((vector? obj) (write-vector obj port recur))
+	((procedure? obj) (write-string "#{Procedure}" port))
+	(((structure-ref code-vectors code-vector?) obj)
+	 (write-string "#{Byte-vector}" port))
+	(((structure-ref low-channels channel?) obj)
+	 (write-string "#{Channel " port)
+	 (display ((structure-ref low-channels channel-id) obj) port)
+	 (write-string "}" port))
+	((eq? obj (if #f #f)) (write-string "#{Unspecific}" port))
+	(else
+	 (write-string "#{Random object}" port))))
+
+; Display the symbol WHO-CARES as Who-cares.
+
+(define (display-type-name name port)
+  (if (symbol? name)
+      (let* ((s (symbol->string name))
+	     (len (string-length s)))
+	(if (and (> len 0)
+		 (char-alphabetic? (string-ref s 0)))
+	    (begin (write-char (char-upcase (string-ref s 0)) port)
+		   (do ((i 1 (+ i 1)))
+		       ((>= i len))
+		     (write-char (char-downcase (string-ref s i)) port)))
+	    (display name port)))
+      (display name port)))
+
+;(define (write-string s port)
+;  (do ((i 0 (+ i 1)))
+;      ((= i (string-length s)))
+;    (write-char (string-ref s i) port)))
+
+
+
+; DISPLAY
+
+(define (display obj . port-option)
+  (let ((port (output-port-option port-option)))
+    (let recur ((obj obj))
+      (cond ((string? obj) (write-string obj port))
+	    ((char? obj) (write-char obj port))
+	    (else
+	     (recurring-write obj port recur))))))
diff --git a/scheme/rts/xnum.scm b/scheme/rts/xnum.scm
new file mode 100644
index 0000000..402f1e3
--- /dev/null
+++ b/scheme/rts/xnum.scm
@@ -0,0 +1,320 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; This is file xnum.scm.
+
+;;;; Extended number support
+
+(define-simple-type :extended-number (:number) extended-number?)
+
+(define-record-type extended-number-type :extended-number-type
+  (really-make-extended-number-type field-names supers priority predicate id)
+  extended-number-type?
+  (field-names extended-number-type-field-names)
+  (supers      extended-number-type-supers)
+  (priority    extended-number-type-priority)
+  (predicate   extended-number-predicate)
+  (id	       extended-number-type-identity))
+
+(define-record-discloser :extended-number-type
+  (lambda (e-n-t)
+    (list 'extended-number-type (extended-number-type-identity e-n-t))))
+
+(define (make-extended-number-type field-names supers id)
+  (letrec ((t (really-make-extended-number-type
+	       field-names
+	       supers
+	       (+ (apply max
+			 (map type-priority
+			      (cons :extended-number supers)))
+		  10)
+	       (lambda (x)
+		 (and (extended-number? x)
+		      (eq? (extended-number-type x) t)))
+	       id)))
+    t))
+
+(define (extended-number-type x) (extended-number-ref x 0))
+
+
+; DEFINE-EXTENDED-NUMBER-TYPE macro
+
+(define-syntax define-extended-number-type
+  (syntax-rules ()
+    ((define-extended-number-type ?type (?super ...)
+       (?constructor ?arg1 ?arg ...)
+       ?predicate
+       (?field ?accessor)
+       ...)
+     (begin (define ?type
+	      (make-extended-number-type '(?field ...)
+					 (list ?super ...)
+					 '?type))
+	    (define ?constructor
+	      (let ((args '(?arg1 ?arg ...)))
+		(if (equal? args
+			    (extended-number-type-field-names ?type))
+		    (let ((k (+ (length args) 1)))
+		      (lambda (?arg1 ?arg ...)
+			(let ((n (make-extended-number k #f))
+			      (i 1))
+			  (extended-number-set! n 0 ?type)
+			  (extended-number-set! n 1 ?arg1)
+			  (begin (set! i (+ i 1))
+				 (extended-number-set! n i ?arg))
+			  ...
+			  n)))
+		    (error "ill-formed DEFINE-EXTENDED-NUMBER-TYPE" '?type))))
+	    (define (?predicate x)
+	      (and (extended-number? x)
+		   (eq? (extended-number-type x) ?type)))
+	    (define-extended-number-accessors ?accessor ...)))))
+
+(define-syntax define-extended-number-accessors
+  (syntax-rules ()
+    ((define-extended-number-accessors ?accessor)
+     (define (?accessor n) (extended-number-ref n 1)))
+    ((define-extended-number-accessors ?accessor1 ?accessor2)
+     (begin (define (?accessor1 n) (extended-number-ref n 1))
+	    (define (?accessor2 n) (extended-number-ref n 2))))
+    ((define-extended-number-accessors ?accessor1 ?accessor2 ?accessor3)
+     (begin (define (?accessor1 n) (extended-number-ref n 1))
+	    (define (?accessor2 n) (extended-number-ref n 2))
+	    (define (?accessor3 n) (extended-number-ref n 3))))))
+
+(define-method &type-priority ((t :extended-number-type))
+  (extended-number-type-priority t))
+
+(define-method &type-predicate ((t :extended-number-type))
+  (extended-number-predicate t))
+
+; Make all the numeric instructions be extensible.
+
+(define (make-opcode-generic! opcode mtable)
+  (let ((perform (method-table-get-perform mtable)))
+    (extend-opcode! opcode
+		    (lambda (lose)
+		      (set-final-method! mtable
+					 (lambda (next-method . args)
+					   (apply lose args)))
+		      (lambda args
+			((perform) args))))))
+		      
+(define-syntax define-opcode-extension
+  (syntax-rules ()
+    ((define-opcode-extension ?name ?table-name)
+     (begin (define ?table-name (make-method-table '?name))
+	    (make-opcode-generic! (enum op ?name) ?table-name)))))
+
+(define-opcode-extension +              &+)
+(define-opcode-extension -              &-)
+(define-opcode-extension *              &*)
+(define-opcode-extension /              &/)
+(define-opcode-extension =              &=)
+(define-opcode-extension <              &<)
+(define-opcode-extension quotient       &quotient)
+(define-opcode-extension remainder      &remainder)
+  
+(define-opcode-extension integer?       &integer?)
+(define-opcode-extension rational?      &rational?)
+(define-opcode-extension real?          &real?)
+(define-opcode-extension complex?       &complex?)
+(define-opcode-extension number?        &number?)
+(define-opcode-extension exact?         &exact?)
+
+(define-opcode-extension exact->inexact &exact->inexact)
+(define-opcode-extension inexact->exact &inexact->exact)
+(define-opcode-extension real-part      &real-part)
+(define-opcode-extension imag-part      &imag-part)
+
+(define-opcode-extension floor          &floor)
+(define-opcode-extension numerator      &numerator)
+(define-opcode-extension denominator    &denominator)
+
+(define-opcode-extension make-rectangular &make-rectangular)
+
+(define-opcode-extension exp  &exp)
+(define-opcode-extension log  &log)
+(define-opcode-extension sin  &sin)
+(define-opcode-extension cos  &cos)
+(define-opcode-extension tan  &tan)
+(define-opcode-extension asin &asin)
+(define-opcode-extension acos &acos)
+(define-opcode-extension atan &atan)
+(define-opcode-extension sqrt &sqrt)
+
+; >, <=, and >= are all extended using the table for <.
+
+(let ((perform (method-table-get-perform &<)))
+  (extend-opcode! (enum op >)
+		  (lambda (lose)
+		    (lambda (x y)
+		      ((perform) (list y x)))))
+  (extend-opcode! (enum op <=)
+		  (lambda (lose)
+		    (lambda (x y)
+		      (not ((perform) (list y x))))))
+  (extend-opcode! (enum op >=)
+		  (lambda (lose)
+		    (lambda (x y)
+		      (not ((perform) (list x y)))))))
+		      
+; Default methods.
+
+(define-method &integer?  (x) #f)
+(define-method &rational? (x) (integer? x))
+(define-method &real?     (x) (rational? x))
+(define-method &complex?  (x) (real? x))
+(define-method &number?   (x) (complex? x))
+
+(define-method &real-part ((x :real)) x)
+
+(define-method &imag-part ((x :real))
+  (if (exact? x) 0 (exact->inexact 0)))
+
+(define-method &floor ((n :integer)) n)
+
+(define-method &numerator ((n :integer)) n)
+
+(define-method &denominator ((n :integer))
+  (if (exact? n) 1 (exact->inexact 1)))
+
+; Make sure this has very low priority, so that it's only tried as a
+; last resort.
+
+(define-method &/ (m n)
+  (if (and (integer? m) (integer? n))
+      (if (= 0 (remainder m n))
+	  (quotient m n)
+	  (let ((z (abs (quotient n 2))))
+	    (set-exactness (quotient (if (< m 0)
+					 (- m z)
+					 (+ m z))
+				     n)
+			   #f)))
+      (next-method)))
+
+(define-method &sqrt ((n :integer))
+  (if (>= n 0)
+      (non-negative-integer-sqrt n)	;Dubious
+      (next-method)))
+
+(define (non-negative-integer-sqrt n)
+  (cond ((<= n 1)    ; for both 0 and 1
+	 n)
+	;; ((< n 0)
+	;;  (make-rectangular 0 (integer-sqrt (- 0 n))))
+	(else
+	 (let loop ((m (quotient n 2)))
+	   (let ((m1 (quotient n m)))
+	     (cond ((< m1 m)
+		    (loop (quotient (+ m m1) 2)))
+		   ((= n (* m m))
+		    m)
+		   (else
+		    (exact->inexact m))))))))
+
+(define-simple-type :exact (:number)
+  (lambda (n) (and (number? n) (exact? n))))
+
+(define-simple-type :inexact (:number)
+  (lambda (n) (and (number? n) (inexact? n))))
+
+
+; Whattakludge.
+
+; Replace the default method (which in the initial image always returns #f).
+
+(define-method &really-string->number (s radix xact?)
+  (let ((len (string-length s)))
+    (cond ((<= len 1) #f)
+	  ((char=? (string-ref s (- len 1)) #\i)
+	   (parse-rectangular s radix xact?))
+	  ((string-position #\@ s)
+	   => (lambda (at)
+		(let ((r (really-string->number (substring s 0 at)
+						radix xact?))
+		      (theta (really-string->number (substring s (+ at 1) len)
+						    radix xact?)))
+		  (if (and (real? r) (real? theta))
+		      (make-polar r theta)))))
+	  ((string-position #\/ s)
+	   => (lambda (slash)
+		(let ((m (string->integer (substring s 0 slash) radix))
+		      (n (string->integer (substring s (+ slash 1) len)
+					  radix)))
+		  (if (and m n)
+		      (set-exactness (/ m n) xact?)
+		      #f))))
+	  ((string-position #\# s)
+	   (if xact?
+	       #f
+	       (really-string->number
+		   (list->string (map (lambda (c) (if (char=? c #\#) #\5 c))
+				      (string->list s)))
+		   radix
+		   xact?)))
+	  ((string-position #\. s)
+	   => (lambda (dot)
+		(parse-decimal s radix xact? dot)))
+	  (else #f))))
+
+(define (parse-decimal s radix xact? dot)
+  ;; Talk about kludges.  This is REALLY kludgey.
+  (let* ((len (string-length s))
+	 (j (if (or (char=? (string-ref s 0) #\+)
+		    (char=? (string-ref s 0) #\-))
+		1
+		0))
+	 (m (if (= dot j)
+		0
+		(string->integer (substring s j dot)
+				 radix)))
+	 (n (if (= dot (- len 1))
+		0
+		(string->integer (substring s (+ dot 1) len)
+				 radix))))
+    (if (and m n)
+	(let ((n (+ m (/ n (expt radix
+				 (- len (+ dot 1)))))))
+	  (set-exactness (if (char=? (string-ref s 0) #\-)
+			     (- 0 n)
+			     n)
+			 xact?))
+	#f)))
+
+(define (parse-rectangular s radix xact?)
+  (let ((len (string-length s)))
+    (let loop ((i (- len 2)))
+      (if (< i 0)
+	  #f
+	  (let ((c (string-ref s i)))
+	    (if (or (char=? c #\+)
+		    (char=? c #\-))
+		(let ((x (if (= i 0)
+			     0
+			     (really-string->number (substring s 0 i)
+						    radix xact?)))
+		      (y (if (= i (- len 2))
+			     (if (char=? c #\+) 1 -1)
+			     (really-string->number (substring s i (- len 1))
+						    radix xact?))))
+		  (if (and (real? x) (real? y))
+		      (make-rectangular x y)
+		      #f))
+		(loop (- i 1))))))))
+
+(define (set-exactness n xact?)
+  (if (exact? n)
+      (if xact? n (exact->inexact n))
+      ;; ?what to do? (if xact? (inexact->exact n) n)
+      n))
+
+; Utility
+
+(define (string-position c s)
+  (let loop ((i 0))
+    (if (>= i (string-length s))
+	#f
+	(if (char=? c (string-ref s i))
+	    i
+	    (loop (+ i 1))))))
diff --git a/scheme/rts/xprim.scm b/scheme/rts/xprim.scm
new file mode 100644
index 0000000..9b67352
--- /dev/null
+++ b/scheme/rts/xprim.scm
@@ -0,0 +1,34 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Hairier exceptions & interrupts.
+; Enable generic arithmetic, informative error messages, etc.
+
+; Deal with optional arguments, etc. to primitives.
+; This is not necessarily the cleanest way to do this, and certainly not
+; the most efficient, but for the time being it's the most expedient.
+
+; We don't want to depend on tables.  But if we did, we might do this:
+;(define (closure-hash closure)
+;  (let ((cv (vector-ref (closure-template closure) 0)))  ;template-ref
+;    (do ((h 0 (+ h (code-vector-ref cv i)))
+;         (i (- (code-vector-length cv) 1) (- i 1)))
+;        ((< i 0) h))))
+;(define wna-handlers (make-table closure-hash))
+
+;(define-exception-handler (enum op check-nargs=)
+;  (lambda (opcode reason proc args)
+;    (let ((probe (assq proc *wna-handlers*)))
+;      (if probe
+;          ((cdr probe) args)
+;          (signal-exception opcode reason proc args)))))
+
+(define *wna-handlers* '())
+
+(define (define-wna-handler proc handler)
+  (set! *wna-handlers* (cons (cons proc handler) *wna-handlers*)))
+
+(define op/check-nargs= (enum op protocol)) ; temporary hack
+
+(define (wna-lose proc args)
+  (signal-exception op/check-nargs= #f proc args))  ; lost our reason
+
diff --git a/scheme/vm/arch.scm b/scheme/vm/arch.scm
new file mode 100644
index 0000000..6f718ab
--- /dev/null
+++ b/scheme/vm/arch.scm
@@ -0,0 +1,457 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; This is file arch.scm.
+
+;;;; Architecture description
+
+(define architecture-version "Vanilla 20")
+
+; Things that the VM and the runtime system both need to know.
+
+(define bits-used-per-byte 8)
+
+(define byte-limit (expt 2 bits-used-per-byte))
+
+; Bytecodes: for compiler and interpreter
+
+; Instruction specification is 
+; (op . args)
+; OP may be a name or a list of names
+; ARGS are
+;  nargs     - a byte
+;  byte      - a byte
+;  junk	     - a byte that is ignored (e.g. when a peephole optimization merges
+;              two instructions into a single, shorter one)
+;  two-bytes - two bytes
+;  index       - a two byte index into the current template
+;  small-index - a one byte index into the current template
+;  offset    - two bytes giving an offset into the current instruction stream
+;  stob      - a byte specifying a type for a stored object
+;  0 1 2 ... - the number of non-instruction-stream arguments (some
+;              instructions take a variable number of arguments; the first
+;              number is the argument count implemented by the VM)
+;  +         - any number of additional arguments are allowed
+
+(define-syntax define-instruction-set
+  (lambda (form rename compare)
+    (let ((data (do ((data (reverse (cdr form)) (cdr data))
+		     (new '() (let ((next (car data)))
+				(if (pair? (car next))
+				    (append (map (lambda (op)
+						   (cons op (cdr next)))
+						 (car next))
+					    new)
+				    (cons next new)))))
+		    ((null? data) new))))
+      `(begin (define-enumeration op
+		,(map car data))
+	      (define opcode-arg-specs
+		'#(,@(map cdr data)))))))
+
+; Instructions marked *EXP* are experimental and are not normally used by
+; byte-code compiler.
+
+(define-instruction-set
+  (protocol       protocol)      ; first opcode in a procedure, never actually
+				 ; executed
+
+  (make-env       two-bytes)     ; cons an environment
+
+  (literal        index)         ; value to *val*, two-byte index
+  (small-literal  small-index)   ; value to *val*, one-byte index
+  (local          byte byte)     ; back and over
+  ((local0 local1 local2)
+   byte)		         ; back encoded into op-code for efficiency
+  (big-local      two-bytes two-bytes)   ; same, but counts are two bytes
+  (set-local!     two-bytes two-bytes 1) ; back over value, counts are two bytes
+  (global         index)         ; value to *val*
+  (set-global!    index 1)
+  (closure        index byte)    ; byte = 0 -> use environment in *env*
+                                 ; byte = 1 -> use environment in *val*
+  (make-flat-env  env-data)      ; make new environment from env-data
+  (push 1)		         ; push *val* onto stack
+  ((local0-push push-local0)	 ; common combination
+		  byte junk 1)
+  (pop)			         ; pop top of stack into *val*
+  (stack-ref      byte)	         ; index'th element of stack into *val*
+  (stack-set!     byte 1)        ; *val* to index'th element of stack
+
+  (make-cont      offset byte)      ; save state in *cont*
+  (make-big-cont  offset two-bytes) ; save state in *cont*, two-byte size
+  (current-cont)	         ; copy *cont* to *val*, use WITH-CONTINUATION
+			         ; to use copied continuation
+  (get-cont-from-heap)	         ; copy next continuation from heap (this
+			         ; op-code is used internally by the VM)
+
+  ;; different ways to call procedures
+  (call     nargs     1 +)       ; last argument is the procedure to call
+  (big-call two-bytes 1 +)       ; ditto, nargs count is two bytes
+  (move-args-and-call nargs 1 +) ; same, move args to just above *cont* first
+  				 ; (*EXP*, and no two-byte version)
+  (apply    two-bytes 2 +)       ; last argument is procedure to call, second to
+				 ; last is a list of additional arguments, next
+                                 ; two bytes are the number of stack arguments
+  (closed-apply 2 +)		 ; arguments are as for Scheme's APPLY, with
+				 ; the number of non-list arguments pushed on
+  				 ; the top of the stack
+  (with-continuation 2)		 ; first arg is cont, second is procedure
+  (call-with-values +)		 ; values are on stack, consumer is in the
+				 ; continuation pointed to by *cont*
+
+  ;; Three different ways to return from calls and one way to ignore any
+  ;; returned values
+  (return 1)			 ; return to continuation in *cont*
+  (values two-bytes +)		 ; values are on stack, count is next two bytes
+  (closed-values +)		 ; values are on stack, count is pushed on stack
+  (ignore-values +)		 ; ignore (and dispose of) returned values
+
+  ;; Different ways to jump
+  (goto-template        index)	 ; jump to another template (*EXP*)
+				 ; does not poll for interrupts
+  (call-template  index nargs)	 ; call a template instead of a procedure
+				 ; nargs is needed for interrupt handling
+  				 ; Current VM only handles the zero-arg case.
+  (jump-if-false  offset 1)	 ; boolean in *val*
+  (jump           offset)
+  (computed-goto  byte offset 1) ; jump using delta specified by *val*
+				 ; defaults to instruction after deltas (*EXP*)
+
+  ;; For the closed-compiled definitions of n-ary arithmetic functions.
+  ;; The opcode sequences used are:
+  ;;       binary-reduce1 binary-op binary-reduce2 return
+  ;; and
+  ;;       binary-reduce1 binary-op binary-comparison-reduce2 return
+  ((binary-reduce1 binary-reduce2 binary-comparison-reduce2))
+
+  ;; Scalar primitives
+  (eq? 2)
+
+  ((number? integer? rational? real? complex? exact?) 1)
+  ((exact->inexact inexact->exact) 1)
+
+  ((+ *) 2 0 1 +)
+  ((- /) 2 1)
+  ((= < > <= >=) 2 +)
+  ((quotient remainder) 2)
+  ((floor numerator denominator
+     real-part imag-part
+     exp log sin cos tan asin acos sqrt
+     angle magnitude)
+   1)
+  (atan 2)
+  ((make-polar make-rectangular) 2)
+  (bitwise-not 1)
+  ((bitwise-and bitwise-ior bitwise-xor) 2)
+  (arithmetic-shift 2)
+  (char? 1)
+  ((char=? char<?) 2)
+  ((char->ascii ascii->char) 1)
+  (eof-object? 1)
+
+  ;; Data manipulation
+  (stored-object-has-type? stob 1)
+  (stored-object-length stob 1)
+
+  (make-stored-object byte stob)
+  (closed-make-stored-object stob) ; size pushed on stack
+  (stored-object-ref  stob byte 1) ; byte is the offset
+  (stored-object-set! stob byte 2)
+
+  (make-vector-object stob 2)	      ; size + init
+  (stored-object-indexed-ref  stob 2) ; vector + offset
+  (stored-object-indexed-set! stob 3) ; vector + offset + value
+
+  (make-byte-vector 2)
+  (byte-vector-length 1)
+  (byte-vector-ref 2)
+  (byte-vector-set! 3)
+
+  (make-string 2)
+  (string-length 1)
+  (string-ref 2)
+  (string-set! 3)
+
+  (intern 1)
+                     
+  (location-defined? 1)
+  (set-location-defined?! 2)
+  ((immutable? make-immutable!) 1)
+
+  ;; channels (unbuffered, non-blocking I/O)
+  (open-channel 2)
+  (close-channel 1)
+  (channel-maybe-read 5)
+  (channel-maybe-write 4)
+  (channel-abort 1)             ; stop channel operation
+  (open-channels-list)		; return a list of the open channels
+  
+  ;; Misc
+  ((unassigned unspecific))
+  (trap 1)			; raise exception
+  (false)			; return #f (for bootstrapping)
+  (eof-object)                  ; hard to get otherwise
+  (write-image 3)
+  (collect)
+  (string-hash 1)		; used by the static linker for the initial table
+  (add-finalizer! 2)
+  (memory-status 2)
+  (find-all 1)	                ; makes a vector of all objects of a given type
+  (find-all-records 1)          ; makes a vector of all records of a given type
+  (current-thread)
+  (set-current-thread! 1)
+  (session-data)                ; session specific data
+  (set-session-data! 1)
+  (set-exception-handlers! 1)
+  (return-from-exception 1)
+  (set-interrupt-handlers! 1)
+  (set-enabled-interrupts! 1)
+  (return-from-interrupt)
+  (schedule-interrupt 1)
+  (wait 2)                      ; do nothing until something happens
+  (call-external-value 1 +)
+  (lookup-shared-binding 2)
+  (define-shared-binding 3)
+  (undefine-shared-binding 2)
+  (time 2)
+  (vm-extension 2)		; access to extensions of the virtual machine
+  (return-from-callback 2)	; return from an callback
+
+  ;; Unnecessary primitives
+  (string=? 2)
+  (reverse-list->string 2)
+  (assq 2)
+  (checked-record-ref 3)
+  (checked-record-set! 4)
+  (copy-bytes! 5)
+
+  ;; ports (buffered I/O) - these are all unnecessary
+  ;; byte = 0 -> port is supplied
+  ;;      = 1 -> get port from dynamic environment
+  ((read-char peek-char) byte 1 0)
+  (write-char byte 2 1)
+
+  ;; For writing informative messages when debugging
+  (message 1)
+  )
+
+(define-enumeration interrupt
+  (alarm           ; order matters - higher priority first
+   keyboard
+   post-gc         ; handler is passed a list of finalizers
+   i/o-completion  ; handler is passed channel and status
+   os-signal
+   ))
+
+; Possible problems
+
+(define-enumeration exception
+  (unassigned-local
+   undefined-global
+   unbound-global
+   bad-procedure
+   wrong-number-of-arguments
+   wrong-type-argument
+   arithmetic-overflow
+   index-out-of-range
+   heap-overflow
+   out-of-memory
+   cannot-open-channel
+   channel-os-index-already-in-use
+   closed-channel
+   pending-channel-i/o
+   buffer-full/empty
+   unimplemented-instruction
+   trap
+   proceeding-after-exception
+   bad-option
+   unbound-external-name
+   too-many-arguments-to-external-procedure
+   too-many-arguments-in-callback
+   callback-return-uncovered
+   extension-exception
+   extension-return-error
+   os-error
+   unresumable-records-in-image
+   gc-protection-mismatch
+   ))
+
+; Used by (READ-CHAR) and (WRITE-CHAR) to get the appropriate ports from
+; the fluid environment.
+
+(define-enumeration current-port-marker
+  (current-input-port
+   current-output-port))
+
+;----------------
+; Encoding for template protocols:
+; 0 ... MAX-STACK-ARGS = that number of arguments, no rest list
+; TWO-BYTE-NARGS = (2*MAX-STACK-ARGS)+1 = next two bytes are the fixed argument
+;  count
+; TWO-BYTE-NARGS+LIST = TWO-BYTE-NARGS + 1 = next two bytes are the fixed
+;  argument count, plus a rest list
+
+(define maximum-stack-args 63)
+
+(define *last-protocol* maximum-stack-args)
+
+(define (next-protocol)
+  (set! *last-protocol* (+ *last-protocol* 1))
+  *last-protocol*)
+
+(define two-byte-nargs-protocol      (next-protocol))
+
+; Used for all n-ary procedures.
+
+(define two-byte-nargs+list-protocol (next-protocol))
+
+; Real protocol is at the end of the code vector, along with the required
+; stack size:
+;   ... real-protocol stack-size0 stack-size1
+; This stuff has to be at the end of the code vector because the necessary stack
+; size is not determined until after the code vector has been assembled.
+
+(define big-stack-protocol (next-protocol))
+
+; The rest are used only for the definitions of various Scheme primitives.
+
+; For VECTOR, RECORD, VALUES, EXTERNAL-CALL, APPLY
+; Next byte is the minimum number of arguments (1 for EXT-CALL, 2 for APPLY,
+; 0 for the rest).
+; Stack = arg0 arg1 ... argN rest-list N+1 total-arg-count
+; The first two arguments are always on the stack.
+
+(define args+nargs-protocol (next-protocol))
+
+; Followed by four bytes: the offsets of code for the 0, 1, 2, and 3+ arg cases.
+; A zero indicatest that the primitive doesn't accept that many arguments.
+; If there are fewer than three arguments they are all on the stack.  In the
+; 3+ case this is the same as args+nargs above.
+
+(define nary-dispatch-protocol (next-protocol))
+
+; The maximum number of arguments that can be passed to EXTERNAL-CALL.
+; This is determined by the C procedure `external_call()'.
+
+(define maximum-external-call-args 12)
+
+;----------------
+; The number of stack slots available to each procedure by default.
+; Procedures that need more than this must use one of the two-byte-nargs
+; protocols.  All of these are given in terms of descriptors.
+
+(define default-stack-space 64)
+
+(define environment-stack-size 2)   ; header + superior environment
+(define continuation-stack-size 5)  ; header + continuation + template +
+                                    ;  pc + env
+
+(define available-stack-space 8000) ; how much stack space is available for
+                                    ; any one procedure
+
+;----------------
+
+; Options for op/time
+
+(define-enumeration time-option
+  (run-time
+   real-time
+   cheap-time     ; cheap (no system call) access to the polling clock
+   ;current-time
+   ))
+
+; Options for op/memory-status
+
+(define-enumeration memory-status-option
+  (available
+   heap-size
+   stack-size
+   gc-count
+   expand-heap!
+   pointer-hash
+   ))
+
+; The two types of special channels cannot be used for normal I/O.
+
+(define-enumeration channel-status-option
+  (closed
+   input
+   output
+   special-input   ; socket accept, ???
+   special-output  ; ???
+   ))
+
+; Indicies into a port's status word
+
+(define-enumeration port-status-options
+  (input
+   output
+   open-for-input
+   open-for-output
+   ))
+
+(define-enumeration stob
+  (;; D-vector types (traced by GC)
+   pair
+   symbol
+   vector
+   closure
+   location
+   channel
+   port
+   ratnum
+   record
+   continuation
+   extended-number
+   template
+   weak-pointer
+   shared-binding
+   unused-d-header1
+   unused-d-header2
+
+   ;; B-vector types (not traced by GC)
+   string        ; = least b-vector type
+   byte-vector
+   double        ; double precision floating point
+   bignum
+   ))
+
+; This is here to try to ensure that it is changed when STOB changes.
+(define least-b-vector-type (enum stob string))
+
+; (stob predicate constructor . (accessor modifier)*)
+; If nothing else, the run-time system and the VM need to agree on
+; which slot of a pair is the car and which is the cdr.
+
+(define stob-data
+  '((pair pair? cons
+      (car set-car!) (cdr set-cdr!))
+    (symbol symbol? #f       ; RTS calls op/string->symbol
+      (symbol->string))
+    (location location? make-location
+      (location-id set-location-id!)
+      (contents set-contents!))
+    (closure closure? make-closure
+      (closure-template) (closure-env))
+    (weak-pointer weak-pointer? make-weak-pointer
+      (weak-pointer-ref))
+    (shared-binding shared-binding? make-shared-binding
+      (shared-binding-name)
+      (shared-binding-is-import?)
+      (shared-binding-ref shared-binding-set!))
+    (port port? make-port
+      (port-handler)
+      (port-status  set-port-status!)
+      (port-lock    set-port-lock!)
+      (port-locked? set-port-locked?!)
+      (port-data    set-port-data!)
+      (port-buffer  set-port-buffer!)
+      (port-index   set-port-index!)
+      (port-limit   set-port-limit!)
+      (port-pending-eof? set-port-pending-eof?!))
+    (channel channel? #f
+      (channel-status)
+      (channel-id)
+      (channel-os-index))
+    ))
+
diff --git a/scheme/vm/arith.scm b/scheme/vm/arith.scm
new file mode 100644
index 0000000..bfcbcf1
--- /dev/null
+++ b/scheme/vm/arith.scm
@@ -0,0 +1,134 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Arithmetic that checks for overflow
+
+(define (carefully op)
+  (lambda (x y succ fail)
+    (let ((z (op (extract-fixnum x) (extract-fixnum y))))
+      (if (or (too-big-for-fixnum? z)
+	      (too-small-for-fixnum? z))
+          (goto fail x y)
+          (goto succ (enter-fixnum z))))))
+
+(define add-carefully (carefully +))
+(define subtract-carefully (carefully -))
+
+(define half-word-size (quotient bits-per-cell 2))
+(define half-word-mask (- (shift-left 1 half-word-size) 1))
+(define max-middle (shift-left 1 (- (- bits-per-fixnum 1) half-word-size)))
+
+; Uses SMALL* to do half-word multiplies.  Some implementations
+; really care about this.
+
+(define (multiply-carefully x y succ fail)
+  (let* ((a (extract-fixnum x))
+         (b (extract-fixnum y))
+         (positive-result? (if (>= a 0)
+                               (>= b 0)
+                               (< b 0)))
+         (a (abs a))
+         (b (abs b))
+	 (lo-a (bitwise-and half-word-mask a))
+	 (lo-b (bitwise-and half-word-mask b))
+         (hi-a (bitwise-and half-word-mask (high-bits a half-word-size)))
+         (hi-b (bitwise-and half-word-mask (high-bits b half-word-size)))
+	 (lo-c (small* lo-a lo-b))
+	 (mid-c (+ (small* lo-a hi-b) (small* lo-b hi-a)))
+	 (c (+ lo-c (shift-left mid-c half-word-size))))
+    (cond ((or (and (> hi-a 0) (> hi-b 0))
+	       (too-big-for-fixnum? lo-c)
+               (> 0 lo-c)
+	       (> mid-c max-middle))
+	   (goto fail x y))
+	  (positive-result?
+	   (if (too-big-for-fixnum? c)
+	       (goto fail x y)
+	       (goto succ (enter-fixnum c))))
+	  (else
+	   (if (too-small-for-fixnum? (- 0 c))
+	       (goto fail x y)
+	       (goto succ (enter-fixnum (- 0 c))))))))
+
+(define small*
+  (external "SMALL_MULTIPLY" (=> (integer integer) integer) *))
+
+; Test cases for bits-per-cell = 28, bits-per-fixnum = 26
+
+;   (do ((i 2 (* i 2))
+;        (j (* -2 (expt 2 23)) (/ j 2)))
+;       ((>= j 0) 'ok)
+;     (write `((* ,i ,j) ?=? ,(* i j)))
+;     (newline))
+
+(define (divide-carefully x y succ fail)
+  (if (= y (enter-fixnum 0))
+      (fail x y)
+      (let* ((a (extract-fixnum x))
+	     (b (extract-fixnum y))
+	     (positive-result? (if (>= a 0)
+				   (>= b 0)
+				   (< b 0)))
+	     (a (abs a))
+	     (b (abs b))
+	     (c (quotient a b)))
+	(cond ((not (= 0 (remainder a b)))
+	       (goto fail x y))
+	      ((not positive-result?)
+	       (goto succ (enter-fixnum (- 0 c))))
+	      ((too-big-for-fixnum? c)  ; (divide least-fixnum -1)
+	       (goto fail x y))
+	      (else
+	       (goto succ (enter-fixnum c)))))))
+
+; Watch out for (quotient least-fixnum -1)
+(define (quotient-carefully x y succ fail)
+  (if (= y (enter-fixnum 0))
+      (fail x y)
+      (let* ((a (extract-fixnum x))
+	     (b (extract-fixnum y))
+	     (positive-result? (if (>= a 0)
+				   (>= b 0)
+				   (< b 0)))
+	     (a (abs a))
+	     (b (abs b))
+	     (c (quotient a b)))
+	(cond ((not positive-result?)
+	       (goto succ (enter-fixnum (- 0 c))))
+	      ((too-big-for-fixnum? c)  ; (quotient least-fixnum -1)
+	       (goto fail x y))
+	      (else
+	       (goto succ (enter-fixnum c)))))))
+
+; Overflow check not necessary
+(define (remainder-carefully x y succ fail)
+  (if (= y (enter-fixnum 0))
+      (goto fail x y)
+      (let* ((a (extract-fixnum x))
+	     (b (extract-fixnum y))
+	     (positive-result? (>= a 0))
+	     (a (abs a))
+	     (b (abs b))
+	     (c (remainder a b)))
+	(goto succ (enter-fixnum (if positive-result? c (- 0 c)))))))
+
+(define (shift-carefully value+tag count+tag succ fail)
+  (let ((value (extract-fixnum value+tag))
+	(count (extract-fixnum count+tag)))
+    (if (< count 0)
+	(goto succ (enter-fixnum (arithmetic-shift-right value (- 0 count))))
+	(let ((result (extract-fixnum (enter-fixnum (shift-left value count)))))
+	  (if (and (= value (arithmetic-shift-right result count))
+		   (if (>= value 0)
+		       (>= result 0)
+		       (< result 0)))
+	      (goto succ (enter-fixnum result))
+	      (goto fail value+tag count+tag))))))
+
+; beware of (abs least-fixnum)
+(define (abs-carefully n succ fail)
+  (let ((r (abs (extract-fixnum n))))
+    (if (too-big-for-fixnum? r)
+	(goto fail n)
+	(goto succ (enter-fixnum r)))))
+
diff --git a/scheme/vm/bignum-low.scm b/scheme/vm/bignum-low.scm
new file mode 100644
index 0000000..1295d43
--- /dev/null
+++ b/scheme/vm/bignum-low.scm
@@ -0,0 +1,42 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Manipulating bignums.
+
+(define (extract-bignum desc)
+  (assert (bignum? desc))
+  (address-after-header desc))
+
+(define (enter-bignum external-bignum)
+  (let ((desc (address->stob-descriptor external-bignum)))
+    (assert (bignum? desc))
+    (make-immutable! desc)
+    desc))
+
+; The extra digit is where the MIT bignum code stores the length.
+
+(define (bignum-alloc number-of-digits key)
+  (make-bignum (cells->bytes (+ number-of-digits 1)) key))
+
+; This doesn't use ENTER-BIGNUM because we need to preserve mutability
+; until the entire bignum operation has completed.
+;
+; If the new size is smaller we change the length in the header and install a
+; new header at the beginning of the now-unused bytes at the end.
+
+(define (shorten-bignum external-bignum number-of-digits)
+  (let ((bignum (address->stob-descriptor external-bignum)))
+    (let ((new-size (cells->bytes
+		      (bignum-size (cells->bytes (+ number-of-digits 1)))))
+	  (old-size (header-lengh-in-bytes (stob-header bignum))))
+      (assert (<= new-size old-size))
+      (if (< new-size old-size)
+	  (begin
+	    (stob-header-set! bignum
+			      (make-header (enum stob bignum) new-size))
+	    (stob-header-set! (address->stob-descriptor
+			         (address+ (address-after-header bignum)
+					   (+ stob-overhead
+					      (bytes->a-units new-size))))
+			      (make-header (enum stob bignum)
+					   (- old-size new-size)))))
+      external-bignum)))
diff --git a/scheme/vm/bignum.scm b/scheme/vm/bignum.scm
new file mode 100644
index 0000000..e86385a
--- /dev/null
+++ b/scheme/vm/bignum.scm
@@ -0,0 +1,156 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; These need to operate on both bignums and fixnums.
+;bignum-add
+;bignum-subtract
+;bignum-multiply
+;bignum-quotient
+;bignum-remainder
+;bignum-abs
+;
+; These only see bignums.
+;bignum=
+;bignum<
+
+; This only sees fixnums.
+;fixnum->bignum
+
+; fixnum-as-bignum-length - the maximum bignum digits required to hold a fixnum
+; From struct.scm:
+;   bignum-length - usual length operator, gives number of descriptors
+;   bignum-size - space to hold a bignum of N descriptors
+; Defined here:
+;   bignum-digits - number of digits in a bignum
+;   bignum-digits->size - space to hold a bignum of N digits
+;   fixnum-as-bignum-digits - number of digits to hold a fixnum
+
+; The first word in a bignum is used as a header by the C code.
+
+(define (bignum-digits bignum)
+  (- (bignum-length bignum) 1))
+
+(define (bignum-digits->size n)
+  (bignum-size (+ n 1)))
+
+;----------------
+
+(define (add-space size0 size1)
+  (bignum-digits->size (+ (max size0 size1) 1)))
+
+(define bignum-add      (binary-bignum-op add-space external-bignum-add))
+(define bignum-subtract (binary-bignum-op add-space external-bignum-subtract))
+
+(define bignum-multiply
+  (binary-bignum-op (lambda (size0 size1)
+		      (bignum-digits->size (+ size0 size1)))
+		    external-bignum-multiply))
+
+; Three bignums whose total length is twice the numerator plus two.
+
+(define (divide-space numerator-size denominator-size)
+  (+ (* 2 (bignum-digits->size numerator-size))
+     (bignum-digits->size 2)))
+
+(define bignum-quotient
+  (binary-bignum-op divide-space external-bignum-quotient))
+
+(define bignum-remainder
+  (binary-bignum-op divide-space external-bignum-remainder))
+
+; These are not applied to fixnums.
+
+(define (bignum= x y)
+  (external-bignum-equal? (extract-bignum x)
+			  (extract-bignum y)))
+
+(define (bignum< x y)
+  (= -1 (external-bignum-compare (extract-bignum x)
+				 (extract-bignum y))))
+
+(define (bignum-abs x)
+  (cond ((bignum? x)
+	 (if (= (external-bignum-test (extract-bignum x))
+		-1)
+	     (external-bignum-negate (extract-bignum x))
+	     x))
+	((fx= x least-bignum)
+	 (long->external-bignum (abs (extract-fixnum x)) key))
+	(else
+	 (enter-fixnum (abs (extract-fixnum x))))))
+
+(define bignum-abs
+  (unary-bignum-op (lambda (size) size)
+		   (lambda (x)
+		     (if (= (external-bignum-test x)
+			    -1)
+			 (external-bignum-negate x)
+			 x))))
+
+;----------------
+
+; While checking for space, which may cause a GC, we have to save the two
+; arguments where they will be traced.
+
+(define (binary-bignum-op space-proc proc)
+  (let ((space-proc (binary-space-proc space-proc)))
+    (lambda (x y)
+      (let ((needed (space-proc x y)))
+	(receive (key x y)
+	    (ensure-space-saving-temps needed x y)
+	  (external-bignum->integer (proc (integer->external-bignum x)
+					  (integer->external-bignum y))))))))
+
+; Same again for unary procedures.
+
+(define (unary-bignum-op space-proc proc)
+  (let ((space-proc (unary-space-proc space-proc)))
+    (lambda (x)
+      (let ((needed (space-proc x)))
+	(receive (key x)
+	    (ensure-space-saving-temp needed x)
+	  (external-bignum->integer (proc (integer->external-bignum x))))))))
+
+; These take care of the extra space needed for fixnum arguments (they need
+; to be converted to bignums).  SPACE-PROC takes the length of the two bignums
+; and returns the space needed for the computation and results.
+
+(define (binary-space-proc space-proc)
+  (lambda (x y)
+    (receive (length0 extra0)
+	(integer-bignum-digits x)
+      (receive (length1 extra1)
+	  (integer-bignum-digits x)
+	(+ (space-proc length0 length1)
+	   extra0
+	   extra1)))))
+
+(define (unary-space-proc space-proc)
+  (lambda (x)
+    (receive (length extra)
+	(integer-bignum-digits x)
+      (+ (space-proc length)
+	 extra))))
+
+; Return the number of bignum digits in an integer.  For fixnums this is a
+; fixed amount.  The second return value is the amount of space needed to
+; convert the argument into a bignum.
+
+(define (integer-bignum-digits x)
+  (if (fixnum? x)
+      (values fixnum-as-bignum-digits
+	      (bignum-digits->size fixnum-as-bignum-digits))
+      (values (bignum-digits x)
+	      0)))
+
+; Converting back and forth between Scheme 48 integers and external bignums.
+
+(define (integer->external-bignum x)
+  (if (fixnum? x)
+      (long->external-bignum (extract-fixnum x))
+      (extract-bignum x)))
+
+(define (external-bignum->integer external-bignum)
+  (if (external-bignum-fits-in-word? external-bignum 30 #t)
+      (enter-fixnum (external-bignum->long external-bignum))
+      (enter-bignum external-bignum)))
diff --git a/scheme/vm/bug.scm b/scheme/vm/bug.scm
new file mode 100644
index 0000000..7bbd296
--- /dev/null
+++ b/scheme/vm/bug.scm
@@ -0,0 +1,12 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+(define (church n)
+  (let loop ((application 'x) (n n))
+    (if (zero? n)
+	`(lambda (f) (lambda (x) ,application))
+	(loop `(f ,application) (- n 1)))))
+
+(define c10000 (church 10000))
+
+(define (f)
+  (eval c10000 (interaction-environment)))
diff --git a/scheme/vm/call.scm b/scheme/vm/call.scm
new file mode 100644
index 0000000..32b72ad
--- /dev/null
+++ b/scheme/vm/call.scm
@@ -0,0 +1,628 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Code to handle the calling conventions.
+
+; *VAL* is the procedure, the arguments are on stack, and the next byte
+; is the protocol.  This checks that *VAL* is in fact a closure and checks
+; for the common case of a non-n-ary procedure that has few arguments.
+; The common case is handled directly and all others are passed off to
+; PLAIN-PROTOCOL-MATCH.
+
+(define-opcode call
+  (let ((stack-arg-count (code-byte 0)))
+    (if (closure? *val*)
+	(let* ((template (closure-template *val*))
+	       (code (template-code template)))
+	  (if (= stack-arg-count (code-vector-ref code 1))
+	      (begin
+		(set! *template* template)
+		(set-current-env! (closure-env *val*))
+		(set-code-pointer! code 2)
+		(ensure-default-procedure-space! ensure-space)
+		(if (pending-interrupt?)
+		    (goto handle-interrupt stack-arg-count)
+		    (goto interpret *code-pointer*)))
+	      (goto plain-protocol-match stack-arg-count)))
+	(goto application-exception
+	      (enum exception bad-procedure)
+	      stack-arg-count null 0))))
+
+; Two bytes of arguments.
+
+(define-opcode big-call
+  (goto perform-application (code-offset 0)))
+
+; Call a template instead of a procedure.  This is currently only used for
+; stringing together the initialization code made by the static linker.
+;
+; **limitation**: this code only works for templates that take no arguments.
+
+(define-opcode call-template
+  (let ((win (lambda ()
+	       (set-template! (get-literal 0)
+			      (enter-fixnum 2)) ; skip the protocol
+	       (if (pending-interrupt?)
+		   (goto handle-interrupt (code-byte 2))  ; pass nargs count
+		   (goto interpret *code-pointer*))))
+	(code (template-code (get-literal 0))))
+    (cond ((= 0 (code-vector-ref code 1))
+	   (ensure-default-procedure-space! ensure-space)
+	   (win))
+	  ((and (= big-stack-protocol (code-vector-ref code 1))
+		(= 0 (code-vector-ref code (- (code-vector-length code) 3))))
+	   (ensure-stack-space! (code-vector-ref16
+				   code
+				   (- (code-vector-length code) 2))
+				ensure-space)
+	   (win))
+	  (else
+	   (raise-exception wrong-type-argument 3 (get-literal 0))))))
+
+; The following two instructions are used only for experiments.  The compiler
+; does not normally use them.
+;
+; Same as op/call except that the arguments are moved to just above the
+; current continuation before the call is made.  For non-tail calls and some
+; tail-calls the arguments will already be there.
+
+(define-opcode move-args-and-call
+  (let ((nargs (code-byte 0)))
+    (move-args-above-cont! nargs)
+    (goto perform-application nargs)))
+
+(define-opcode goto-template
+  (set-template! (get-literal 0) (enter-fixnum 0))
+  (goto interpret *code-pointer*))
+
+; APPLY: *VAL* is the procedure, the rest-arg list is on top of the stack,
+; the next two bytes are the number of stack arguments below the rest-args list.
+; We check that the rest-arg list is a proper list and let
+; PERFORM-APPLICATION-WITH-REST-LIST do the work.
+    
+(define-opcode apply
+  (let ((list-args (pop)))
+    (receive (okay? length)
+	(okay-argument-list list-args)
+      (if okay?
+	  (goto perform-application-with-rest-list
+		(code-offset 0) list-args length)
+	  (begin
+	    (push list-args)
+	    (let ((args (pop-args->list* null (+ (code-offset 0) 1))))
+	      (raise-exception wrong-type-argument -1 *val* args))))))) ; no next
+
+; This is only used for the closed-compiled version of APPLY.
+;
+; Stack = arg0 arg1 ... argN rest-list N+1 total-arg-count
+; Arg0 is the procedure.
+;
+; Note that the rest-list on the stack is the rest-list passed to APPLY
+; procedure and not the rest-list to be used in the call to the procedure.
+; Consider (APPLY APPLY (LIST LIST '(1 2 3))), where the initial APPLY
+; is not done in-line.  The stack for the inner call to APPLY will be
+; [(<list-procedure> (1 2 3)), 1, 2], whereas for
+; (APPLY APPLY LIST 1 '(2 (3))) the stack will be
+; [<list-procedure>, 1, (2 (3)), 3, 4].
+;
+; We grab the counts and the procedure, and clobber the procedure's stack
+; slot for GC safety.  Then we get the true stack-arg count and list args
+; and again let PERFORM-APPLICATION-WITH-REST-LIST do the work.
+
+(define-opcode closed-apply
+  (let* ((nargs (extract-fixnum (pop)))
+	 (stack-nargs (extract-fixnum (pop)))
+	 (proc (stack-ref stack-nargs)))
+    (stack-set! stack-nargs false)
+    (receive (okay? stack-arg-count list-args list-arg-count)
+	(get-closed-apply-args nargs stack-nargs)
+      (if okay?
+	  (begin
+	    (set! *val* proc)
+	    (goto perform-application-with-rest-list
+		  stack-arg-count
+		  list-args
+		  list-arg-count))
+	  (begin
+	    (push list-args)
+	    (let ((args (pop-args->list* null (+ stack-arg-count 1))))
+	      (pop)	; remove procedure
+	      (raise-exception wrong-type-argument -1 proc args)))))))
+
+; Stack = arg0 arg1 ... argN rest-list
+; This needs to get the last argument, which is either argN or the last
+; element of the rest-list, and splice it into the rest of the arguments.
+; If the rest-list is null, then argN is the last argument and becomes the
+; new rest-list.  If the rest-list is non-null, then we go to the end, get
+; the list there, and splice the two together to make a single list.
+; This only happens if someone does (APPLY APPLY ...).
+
+(define (get-closed-apply-args nargs stack-nargs)
+  (let ((rest-list (pop)))
+    (receive (list-args stack-nargs)
+	(cond ((vm-eq? rest-list null)
+	       (values (pop)
+		       (- stack-nargs 2))) ; drop proc and final list
+	      ((vm-eq? (vm-cdr rest-list) null)
+	       (values (vm-car rest-list)
+		       (- stack-nargs 1))) ; drop proc
+	      (else
+	       (let* ((penultimate-cdr (penultimate-cdr rest-list))
+		      (list-args (vm-car (vm-cdr penultimate-cdr))))
+		 (vm-set-cdr! penultimate-cdr list-args)
+		 (values rest-list
+			 (- stack-nargs 1))))) ; drop proc
+      (receive (okay? list-arg-count)
+	  (okay-argument-list list-args)
+	(values okay?
+		stack-nargs
+		list-args
+		list-arg-count)))))
+
+; If LIST is a proper list (the final cdr is null) then we return #T and the
+; length of the list, otherwise we return #F.
+
+(define (okay-argument-list list)
+  (let loop ((fast list) (len 0) (slow list) (move-slow? #f))
+    (cond ((vm-eq? null fast)
+	   (values #t len))
+	  ((or (not (vm-pair? fast)))
+	   (values #f 0))
+	  ((not move-slow?)
+	   (loop (vm-cdr fast) (+ len 1) slow #t))
+	  ((vm-eq? fast slow)
+	   (values #f 0))
+	  (else
+	   (loop (vm-cdr fast) (+ len 1) (vm-cdr slow) #f)))))
+
+; Return the second-to-last cdr of LIST.
+
+(define (penultimate-cdr list)
+  (let loop ((list (vm-cdr (vm-cdr list))) (follower list))
+    (if (eq? null list)
+	follower
+	(loop (vm-cdr list) (vm-cdr follower)))))
+
+;----------------
+; Call the procedure in *VAL*.  STACK-ARG-COUNT is the number of arguments
+; on the stack, LIST-ARGS is a list of LIST-ARG-COUNT additional arguments.
+;
+; The CLOSURE? and protocol checks must come before the interrupt check because
+; the interrupt code assumes that the correct template is in place.  This delays
+; the handling of interrupts by a few instructions; it shouldn't matter.
+
+(define (perform-application stack-arg-count)
+  (if (closure? *val*)
+      (goto plain-protocol-match stack-arg-count)
+      (goto application-exception
+	    (enum exception bad-procedure)
+	    stack-arg-count null 0)))
+
+(define (perform-application-with-rest-list stack-arg-count
+					    list-args list-arg-count)
+  (cond ((= 0 list-arg-count)
+	 (goto perform-application stack-arg-count))
+	((closure? *val*)
+	 (goto list-protocol-match
+	       stack-arg-count list-args list-arg-count))
+	(else
+	 (goto application-exception
+	       (enum exception bad-procedure)
+	       stack-arg-count list-args list-arg-count))))
+
+(define (install-*val*-closure skip)
+  (let ((template (closure-template *val*)))
+    (set! *template* template)
+    (set-code-pointer! (template-code template) skip)
+    (set-current-env! (closure-env *val*))))
+
+(define (check-interrupts-and-go stack-slots stack-arg-count)
+  (ensure-stack-space! stack-slots ensure-space)
+  (if (pending-interrupt?)
+      (goto handle-interrupt stack-arg-count)
+      (goto interpret *code-pointer*)))
+
+(define (wrong-nargs stack-arg-count list-args list-arg-count)
+  (goto application-exception
+	(enum exception wrong-number-of-arguments)
+	stack-arg-count list-args list-arg-count))
+
+; Used by RAISE which can't raise an exception when an error occurs.
+
+(define *losing-opcode* 0)
+
+(define (call-exception-handler stack-arg-count opcode)
+  (set! *template* *val*)  ; Use *VAL* (a closure) as a marker.
+  (set! *losing-opcode* opcode)
+  (goto plain-protocol-match stack-arg-count))
+
+(define (call-interrupt-handler stack-arg-count interrupt)
+  (set! *template* *val*)  ; Use *VAL* (a closure) as a marker.
+  (set! *losing-opcode* (- interrupt))
+  (goto plain-protocol-match stack-arg-count))
+
+; Check that the arguments match those needed by *VAL*, which is a closure,
+; moving arguments to or from the stack if necessary, and ensure that there
+; is enough stack space for the procedure.  The environment needed by *VAL*
+; is created.
+
+(define (plain-protocol-match stack-arg-count)
+  (let ((code (template-code (closure-template *val*)))
+	(lose (lambda ()
+		(goto wrong-nargs stack-arg-count null 0))))
+    (assert (= (enum op protocol)
+	       (code-vector-ref code 0)))
+    (let loop ((protocol (code-vector-ref code 1))
+	       (stack-space default-stack-space))
+      (let ((win (lambda (skip stack-arg-count)
+		   (install-*val*-closure skip)
+		   (goto check-interrupts-and-go stack-space stack-arg-count))))
+	(let (;; Fixed number of arguments.
+	      (fixed-match (lambda (wants skip)
+			     (if (= wants stack-arg-count)
+				 (win skip stack-arg-count)
+				 (lose))))
+	      ;; N-ary procedure.
+	      (n-ary-match (lambda (wants-stack-args skip)
+			     (if (<= wants-stack-args stack-arg-count)
+				 (begin
+				   (rest-list-setup wants-stack-args
+						    stack-arg-count
+						    null
+						    0)
+				   (win skip (+ wants-stack-args 1)))
+				 (lose))))
+	      ;; Push the rest list, the total number of arguments, and the
+	      ;; number on the stack arguments onto the stack.
+	      (args+nargs-match (lambda (skip)
+				  (push null)
+				  (push (enter-fixnum stack-arg-count))
+				  (push (enter-fixnum stack-arg-count))
+				  (win skip (+ stack-arg-count 3)))))
+	  (cond ((= protocol nary-dispatch-protocol)
+		 (if (< stack-arg-count 3)
+		     (let ((skip (code-vector-ref code (+ 2 stack-arg-count))))
+		       (if (= 0 skip)
+			   (lose)
+			   (win skip stack-arg-count)))
+		     (let ((skip (code-vector-ref code 5)))
+		       (if (= 0 skip)
+			   (lose)
+			   (args+nargs-match skip)))))
+		((= protocol args+nargs-protocol)
+		 (if (>= stack-arg-count
+			 (code-vector-ref code 2))
+		     (args+nargs-match 3)
+		     (lose)))
+		((= protocol two-byte-nargs+list-protocol)
+		 (n-ary-match (code-vector-ref16 code 2) 4))
+		((<= protocol maximum-stack-args)
+		 (fixed-match protocol 2))
+		((= protocol two-byte-nargs-protocol)
+		 (fixed-match (code-vector-ref16 code 2) 4))
+		((= protocol big-stack-protocol)
+		 (let ((length (code-vector-length code)))
+		   (loop (code-vector-ref code (- length 3))
+			 (code-vector-ref16 code (- length 2)))))
+		(else
+		 (error "unknown protocol" protocol)
+		 (lose))))))))
+
+; Same thing, except that there is an additional list of arguments.
+
+(define (list-protocol-match stack-arg-count list-args list-arg-count)
+  (let ((code (template-code (closure-template *val*)))
+	(total-arg-count (+ stack-arg-count list-arg-count))
+	(lose (lambda ()
+		(goto wrong-nargs
+		      stack-arg-count list-args list-arg-count))))
+    (assert (= (enum op protocol)
+	       (code-vector-ref code 0)))
+    (let loop ((protocol (code-vector-ref code 1))
+	       (stack-space default-stack-space))
+      (let ((win (lambda (skip stack-arg-count)
+		   (install-*val*-closure skip)
+		   (goto check-interrupts-and-go stack-space stack-arg-count))))
+	(let (;; Fixed number of arguments.
+	      (fixed-match (lambda (wants skip)
+			     (if (= wants total-arg-count)
+				 (begin
+				   (push-list list-args list-arg-count)
+				   (win skip total-arg-count))
+				 (lose))))
+	      ;; N-ary procedure.
+	      (n-ary-match (lambda (wants-stack-args skip)
+			     (if (<= wants-stack-args total-arg-count)
+				 (begin
+				   (rest-list-setup wants-stack-args
+						    stack-arg-count
+						    list-args
+						    list-arg-count)
+				   (win skip (+ wants-stack-args 1)))
+				 (lose))))
+	      ;; If there are > 2 args the top two are pushed on the stack.
+	      ;; Then the remaining list, the total number of arguments, and
+	      ;; the number on the stack are pushed on the stack.
+	      (args+nargs-match (lambda (skip)
+				  (let ((final-stack-arg-count
+					 (if (< total-arg-count 3)
+					     total-arg-count
+					     (max 2 stack-arg-count))))
+				    (rest-list-setup (max stack-arg-count
+							  final-stack-arg-count)
+						     stack-arg-count
+						     list-args
+						     list-arg-count)
+				    (push (enter-fixnum final-stack-arg-count))
+				    (push (enter-fixnum total-arg-count))
+				    (win skip (+ final-stack-arg-count 3))))))
+	  (cond ((= protocol nary-dispatch-protocol)
+		 (if (< total-arg-count 3)
+		     (let ((skip (code-vector-ref code (+ 2 total-arg-count))))
+		       (if (= 0 skip)
+			   (lose)
+			   (begin
+			     (push-list list-args list-arg-count)
+			     (win skip total-arg-count))))
+		     (let ((skip (code-vector-ref code 5)))
+		       (if (= 0 skip)
+			   (lose)
+			   (args+nargs-match skip)))))
+		((= protocol args+nargs-protocol)
+		 (if (>= total-arg-count
+			 (code-vector-ref code 2))
+		     (args+nargs-match 3)
+		     (lose)))
+		((<= protocol maximum-stack-args)
+		 (fixed-match protocol 2))
+		((= protocol two-byte-nargs+list-protocol)
+		 (n-ary-match (code-vector-ref16 code 2) 4))
+		((= protocol two-byte-nargs-protocol)
+		 (fixed-match (code-vector-ref16 code 2) 4))
+		((= protocol big-stack-protocol)
+		 (let ((length (code-vector-length code)))
+		   (loop (code-vector-ref code (- length 3))
+			 (code-vector-ref16 code (- length 2)))))
+		(else
+		 (error "unknown protocol" protocol)
+		 (lose))))))))
+
+; Adjusts the number of stack arguments to be WANTS-STACK-ARGS by moving
+; arguments between the stack and LIST-ARGS as necessary.  Whatever is left
+; of LIST-ARGS is then copied and the copy is pushed onto the stack.
+
+(define (rest-list-setup wants-stack-args stack-arg-count list-args list-arg-count)
+  (cond ((= stack-arg-count wants-stack-args)
+	 (push (copy-list* list-args list-arg-count)))
+	((< stack-arg-count wants-stack-args)
+	 (let ((count (- wants-stack-args stack-arg-count)))
+	   (push (copy-list* (push-list list-args count)
+			     (- list-arg-count count)))))
+	(else ; (> stack-arg-count wants-stack-args)
+	 (let ((count (- stack-arg-count wants-stack-args)))
+	   (push (pop-args->list* (copy-list* list-args list-arg-count)
+				  count))))))
+
+; Raise an exception, passing to it a list of the arguments on the stack and
+; in LIST-ARGS.
+
+(define (application-exception exception
+			       stack-arg-count list-args list-arg-count)
+  (cond ((not (vm-eq? *template* *val*))
+	 (let ((args (pop-args->list* (copy-list* list-args list-arg-count)
+				      stack-arg-count)))
+	   (raise-exception* exception -1 *val* args))) ; no next opcode
+	((< 0 *losing-opcode*)
+	 (error "wrong number of arguments to exception handler"
+		*losing-opcode*))
+	(else
+	 (error "wrong number of arguments to interrupt handler"
+		(- *losing-opcode*)))))
+
+;(define (application-exception exception stack-arg-count list-args list-arg-count)
+;  (if (vm-eq? *template* *val*)
+;      (error "wrong number of arguments to exception handler"
+;             *losing-opcode*)
+;      (let ((args (pop-args->list* (copy-list* list-args list-arg-count)
+;                                   stack-arg-count)))
+;        (push (enter-fixnum (current-opcode)))
+;        (push (enter-fixnum exception))
+;        (push *val*)
+;        (push args)
+;        (goto raise 2))))
+
+; Get a two-byte number from CODE-VECTOR.
+
+(define (code-vector-ref16 code-vector index)
+  (let ((high (code-vector-ref code-vector index)))
+    (adjoin-bits high
+		 (code-vector-ref code-vector (+ index 1))
+		 bits-used-per-byte)))
+
+;----------------
+; Manipulating lists of arguments
+
+; Push COUNT elements from LIST onto the stack, returning whatever is left.
+
+(define (push-list list count)
+  (push list)
+  (ensure-stack-space! count ensure-space)
+  (let ((list (pop)))
+    (do ((i count (- i 1))
+	 (l list (vm-cdr l)))
+	((<= i 0) l)
+      (push (vm-car l)))))
+
+; Copy LIST, which has LENGTH elements.
+
+(define (copy-list* list length)
+  (if (= length 0)
+      null
+      (receive (key list)
+	  (ensure-space-saving-temp (* vm-pair-size length) list)
+	(let ((res (vm-cons (vm-car list) null key)))
+	  (do ((l (vm-cdr list) (vm-cdr l))
+	       (last res (let ((next (vm-cons (vm-car l) null key)))
+			   (vm-set-cdr! last next)
+			   next)))
+	      ((vm-eq? null l)
+	       res))))))
+
+; Pop COUNT arguments into a list with START as the cdr.
+
+(define (pop-args->list* start count)
+  (receive (key start)
+      (ensure-space-saving-temp (* vm-pair-size count) start)
+    (do ((args start (vm-cons (pop) args key))
+	 (count count (- count 1)))
+	((= count 0)
+	 args))))
+
+;----------------
+; Opcodes for the closed-compiled versions of arithmetic primitives.
+; The opcode sequences used are:
+;   binary-reduce1 binary-op binary-reduce2 return
+; and
+;   compare-reduce1 binary-comparison-op compare-reduce2 return
+; The compare version quits if the comparison operator returns false.
+;
+; For ...-reduce1 the stack looks like:
+;   arg0 arg1 ... argN rest-list N+1
+; If there are two or more arguments then at least two arguments are on the
+; stack.
+
+; Turn
+;   *stack* = arg0 (arg1 . more) <3
+; into
+;   *val* = arg1, *stack* = arg0 (arg1 .more) 1 arg0
+; or turn
+;   *stack* = arg0 arg1 ... argN rest-list N+1
+; into
+;   *val* = arg1, *stack* = false arg1 ... argN rest-list N arg0
+
+(define-opcode binary-reduce1
+  (let ((stack-nargs (extract-fixnum (stack-ref 0))))
+    (if (= stack-nargs 0)
+	(let ((rest-list (stack-ref 1))
+	      (arg0 (stack-ref 2)))
+	  (push arg0)
+	  (set! *val* (vm-car rest-list)))
+	(let ((arg0 (stack-ref (+ stack-nargs 1)))
+	      (arg1 (stack-ref stack-nargs)))
+	  (stack-set! (+ stack-nargs 1) false)
+	  (stack-set! 0 (enter-fixnum (- stack-nargs 1)))
+	  (push arg0)
+	  (set! *val* arg1)))
+    (goto continue 0)))
+
+; Turn
+;   *val* = result, *stack* = arg0 (arg1 . more) 2
+; into
+;   *stack* = result more 2
+; or turn
+;   *val* = result, *stack* = arg1 ... argN rest-list N
+; into
+;   *stack* = result ... argN rest-list N
+
+(define-opcode binary-reduce2
+  (let* ((stack-nargs (extract-fixnum (stack-ref 0)))
+	 (delta (case stack-nargs
+		  ((0)
+		   (let ((rest-list (stack-ref 1)))
+		     (if (vm-eq? (vm-cdr rest-list) null)
+			 1
+			 (begin
+			   (stack-set! 1 (vm-cdr rest-list))
+			   (stack-set! 2 *val*)
+			   -2))))
+		  ((1)
+		   (let ((rest-list (stack-ref 1)))
+		     (if (vm-eq? rest-list null)
+			 1
+			 (begin
+			   (stack-set! 0 (enter-fixnum 0))
+			   (stack-set! 2 *val*)
+			   -2))))
+		  (else
+		   (stack-set! (+ stack-nargs 1) *val*)
+		   -2))))
+    (set! *code-pointer* (address+ *code-pointer* delta))
+    (goto interpret *code-pointer*)))
+
+(define-opcode binary-comparison-reduce2
+  (if (false? *val*)
+      (goto continue 0)
+      (let* ((stack-nargs (extract-fixnum (stack-ref 0)))
+	     (delta (case stack-nargs
+		      ((0)
+		       (let ((rest-list (stack-ref 1)))
+			 (if (vm-eq? (vm-cdr rest-list) null)
+			     1
+			     (begin
+			       (stack-set! 1 (vm-cdr rest-list))
+			       (stack-set! 2 (vm-car rest-list))
+			       -2))))
+		      ((1)
+		       (let ((rest-list (stack-ref 1)))
+			 (if (vm-eq? rest-list null)
+			     1
+			     (begin
+			       (stack-set! 0 (enter-fixnum 0))
+			       -2))))
+		      (else
+		       -2))))
+	(set! *code-pointer* (address+ *code-pointer* delta))
+	(goto interpret *code-pointer*))))
+
+;----------------
+; Statistics stuff
+;
+;(define call-stats (make-vector 16 0))
+;
+;		(let ((i (min stack-arg-count 15)))
+;		  (vector-set! call-stats i (+ 1 (vector-ref call-stats i))))
+;
+;(define plain-calls (make-vector 7 0))
+;
+;(define (add-plain-call i)
+;  (vector-set! plain-calls i (+ (vector-ref plain-calls i) 1)))
+;
+;(define apply-calls (make-vector 7 0))
+;
+;(define (add-apply-call i)
+;  (vector-set! apply-calls i (+ (vector-ref apply-calls i) 1)))
+;
+;(define (dump-call-stats)
+;  (let ((out (current-output-port)))
+;    (write-string "Calls:" out)
+;    (do ((i 0 (+ i 1)))
+;        ((= i 16))
+;      (write-char #\space out)
+;      (write-integer (vector-ref call-stats i) out))
+;    (write-char #\newline out)
+;    (write-string "Plain calls" out)
+;    (write-char #\newline out)
+;    (do ((i 0 (+ i 1)))
+;        ((= i 7))
+;      (write-char #\space out)
+;      (write-string (vector-ref call-strings i) out)
+;      (write-integer (vector-ref plain-calls i) out)
+;      (write-char #\newline out))
+;    (write-string "Apply calls" out)
+;    (write-char #\newline out)
+;    (do ((i 0 (+ i 1)))
+;        ((= i 7))
+;      (write-char #\space out)
+;      (write-string (vector-ref call-strings i) out)
+;      (write-integer (vector-ref apply-calls i) out)
+;      (write-char #\newline out))))
+;
+;(define call-strings
+;  '#("nary-dispatch: "
+;     "args&nargs: "
+;     "no-env: "
+;     "two-bytes-nargs+list: "
+;     "plain: "
+;     "two-byte-nargs: "
+;     "big-stack: "))
+     
+
diff --git a/scheme/vm/data.scm b/scheme/vm/data.scm
new file mode 100644
index 0000000..0eef61b
--- /dev/null
+++ b/scheme/vm/data.scm
@@ -0,0 +1,267 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; This is file data.scm.
+; Requires DEFINE-ENUMERATION macro.
+
+;;;; Data representations
+
+; This implementation of the data representations is particularly
+; tuned for byte-addressable machines with 4 bytes per word.
+; Good representations for other kinds of machines would necessarily
+; look quite different; e.g. on a word-addressed machine you might
+; want to put tag bits in the high end of a word, or even go to some
+; kind of BIBOP system.
+
+; Descriptors
+;  A descriptor describes a Scheme object.
+;  A descriptor is represented as an integer whose low two bits are
+;  tag bits.  The high bits contain information whose format and
+;  meaning are dependent on the tag.
+
+(define tag-field-width 2)
+(define data-field-width (- bits-per-cell tag-field-width))
+
+(define (make-descriptor tag data)
+  (adjoin-bits data tag tag-field-width))
+
+(define (descriptor-tag descriptor)
+  (low-bits descriptor tag-field-width))
+
+(define (descriptor-data descriptor)
+  (high-bits descriptor tag-field-width))
+
+(define (unsigned-descriptor-data descriptor)
+  (unsigned-high-bits descriptor tag-field-width))
+
+(define (set-descriptor-tag proto-descriptor tag)
+  (assert (= 0 (descriptor-tag proto-descriptor)))
+  (+ proto-descriptor tag))
+
+(define vm-eq? =)
+
+; The four tags are: fixnum, immediate (character, boolean, etc.),
+; header (gives the type and size of a stored object), and stored
+; (pointer into memory).
+; The header and immediate tags could be multiplexed, thus freeing up
+; one of the 4 type codes for some other purpose, but the
+; implementation is simpler if they're not.
+
+(define-enumeration tag
+  (fixnum
+   immediate
+   header
+   stob))
+
+;; (assert (>= (shift-left 1 tag-field-width)
+;;             (vector-length tag)))
+
+(define (fixnum? descriptor)
+  (= (descriptor-tag descriptor) (enum tag fixnum)))
+
+(define (immediate? descriptor)
+  (= (descriptor-tag descriptor) (enum tag immediate)))
+
+(define (header? descriptor)
+  (= (descriptor-tag descriptor) (enum tag header)))
+
+(define (stob? descriptor)
+  (= (descriptor-tag descriptor) (enum tag stob)))
+
+; Fixnums
+
+(define bits-per-fixnum
+  (- (if (< bits-per-cell useful-bits-per-word)
+          bits-per-cell
+          useful-bits-per-word)
+      tag-field-width))
+
+(define    least-fixnum-value (- 0 (shift-left 1 (- bits-per-fixnum 1))))
+(define greatest-fixnum-value (-   (shift-left 1 (- bits-per-fixnum 1)) 1))
+
+(define (too-big-for-fixnum? n)
+  (> n greatest-fixnum-value))
+
+(define (too-small-for-fixnum? n)
+  (< n least-fixnum-value))
+
+(define (enter-fixnum n)
+  (assert (not (or (too-big-for-fixnum? n)
+		   (too-small-for-fixnum? n))))
+  (make-descriptor (enum tag fixnum) n))
+
+(define (extract-fixnum p)
+  (assert (fixnum? p))
+  (descriptor-data p))
+
+(define (descriptor->fixnum p)
+  (enter-fixnum (descriptor-data p)))
+
+; These happen to work out, given our representation for fixnums.
+(define fixnum= =)
+(define fixnum< <)
+(define fixnum> >)
+(define fixnum<= <=)
+(define fixnum>= >=)
+
+(define (fixnum-bitwise-not x)
+  (bitwise-not (bitwise-ior x 3)))
+(define fixnum-bitwise-and bitwise-and)
+(define fixnum-bitwise-ior bitwise-ior)
+(define fixnum-bitwise-xor bitwise-xor)
+
+;----------------
+; Immediates
+;  The number 8 is chosen to streamline 8-bit-byte-oriented implementations.
+
+(define immediate-type-field-width
+  (- 8 tag-field-width))
+
+(define (make-immediate type info)
+  (make-descriptor (enum tag immediate)
+                   (adjoin-bits info type immediate-type-field-width)))
+
+(define (immediate-type imm)
+  (assert (immediate? imm))
+  (low-bits (descriptor-data imm)
+             immediate-type-field-width))
+
+(define (immediate-info imm)
+  (assert (immediate? imm))
+  (high-bits (descriptor-data imm)
+              immediate-type-field-width))
+
+(define (tag&immediate-type descriptor)
+  (low-bits descriptor (+ tag-field-width immediate-type-field-width)))
+
+(define (make-tag&immediate-type type)
+  (adjoin-bits type (enum tag immediate) tag-field-width))
+
+(define-enumeration imm
+  (false      ; #f
+   true       ; #t
+   char
+   unspecific
+   undefined
+   eof
+   null))
+
+;; (assert (>= (shift-left 1 immediate-type-field-width)
+;;             (vector-length imm)))
+
+(define (immediate-predicate type)
+  (lambda (descriptor)
+    ;; Check low 8 bits...
+    (= (tag&immediate-type descriptor)
+	(make-tag&immediate-type type))))
+
+(define vm-char?   (immediate-predicate (enum imm char)))
+(define undefined? (immediate-predicate (enum imm undefined)))
+
+(define true          (make-immediate (enum imm true) 0))
+(define false         (make-immediate (enum imm false) 0))
+(define eof-object    (make-immediate (enum imm eof)  0))
+(define null          (make-immediate (enum imm null) 0))
+(define unspecific-value  (make-immediate (enum imm unspecific) 0))
+(define quiescent         (make-immediate (enum imm undefined) 0))
+(define unbound-marker    (make-immediate (enum imm undefined) 1))
+(define unassigned-marker (make-immediate (enum imm undefined) 2))
+
+(define (false? x)
+  (vm-eq? x false))
+
+(define (enter-boolean b)
+  (if b true false))
+
+(define (extract-boolean b)
+  (assert (vm-boolean? b))
+  (if (false? b) #f #t))
+
+(define (vm-boolean? x)
+  (or (vm-eq? x false)
+      (vm-eq? x true)))
+
+; Characters
+
+(define (enter-char c)
+  (make-immediate (enum imm char) (char->ascii c)))
+
+(define (extract-char d)
+  (assert (vm-char? d))
+  (ascii->char (immediate-info d)))
+
+; these work given the representations
+(define vm-char=? =)
+(define vm-char<? <)
+
+; Headers
+
+(define header-type-field-width (- immediate-type-field-width 1))
+
+(define header-size-field-width (- data-field-width immediate-type-field-width))
+
+; Assumes headers sizes are extracted as unsigned.
+
+(define max-stob-contents-size-in-cells
+  (bytes->cells (- (shift-left 1 header-size-field-width) 1)))
+
+(define (make-header type length-in-bytes)
+  (make-descriptor (enum tag header)
+		   (adjoin-bits length-in-bytes
+				type
+				(+ 1 header-type-field-width))))
+
+(define header-immutable-bit-mask
+  (adjoin-bits 1 0 (+ header-type-field-width tag-field-width)))
+
+(define (make-header-immutable header)
+  (bitwise-ior header header-immutable-bit-mask))
+
+(define (header-type h)
+  (assert (header? h))
+  (low-bits (descriptor-data h)
+             header-type-field-width))
+
+(define (immutable-header? h)
+  (assert (header? h))
+  (not (= 0 (bitwise-and h header-immutable-bit-mask))))
+
+(define (header-length-in-bytes h)
+  (assert (header? h))
+  (unsigned-high-bits (unsigned-descriptor-data h)
+		      (+ 1 header-type-field-width)))
+
+(define (header-length-in-cells header)
+  (bytes->cells (header-length-in-bytes header)))
+
+(define (header-length-in-a-units h)
+  (cells->a-units (header-length-in-cells h)))
+
+(define (d-vector-header? h)
+  (< (header-type h) least-b-vector-type))
+
+(define (b-vector-header? h)
+  (and (header? h)
+       (>= (header-type h) least-b-vector-type)))
+
+; Stored objects
+;  The data field of a descriptor for a stored object contains the
+;  cell number of the first cell after the object's header cell.
+
+(define (address->stob-descriptor addr)
+  (set-descriptor-tag (address->integer addr) (enum tag stob)))
+
+(define stob-overhead 1)  ; header uses up one descriptor
+
+(define (address-after-header stob)
+  (assert (stob? stob))
+  (integer->address (- stob (enum tag stob))))
+
+(define (address-at-header stob)
+  (address- (address-after-header stob) (cells->a-units 1)))
+
+(define (stob-header stob)
+  (fetch (address-at-header stob)))
+
+(define (stob-header-set! stob header)
+  (store! (address-at-header stob) header))
diff --git a/scheme/vm/debug-package.scm b/scheme/vm/debug-package.scm
new file mode 100644
index 0000000..81b104f
--- /dev/null
+++ b/scheme/vm/debug-package.scm
@@ -0,0 +1,78 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; For debugging
+
+(define-structure vm-disassembler (export disassemble write-instruction)
+  (open scheme
+	struct
+        enumerated              ; enumerand->name
+        vm-architecture
+	bitwise                 ; arithmetic-shift
+	signals)                ; error
+  (files disasm))
+
+; Independent byte-code compiler for testing (from Michael Sperber).
+
+(define-structure scan-test scan-interface
+  (open scheme-level-2
+	packages syntactic
+	usual-macros		; for dealing with (usual-transforms ...)
+	meta-types
+	packages-internal
+	signals fluids tables util
+	features		;force-output current-noise-port
+	filenames)		;translate
+  (files (bcomp scan)
+	 (bcomp undefined)))
+
+(define-structure expander-test expander-interface
+  (open scheme-level-2
+	syntactic packages scan-test meta-types reconstruction
+	define-record-types
+	util signals tables fluids strong
+	features)  ; string-hash
+  (files (opt expand)
+         (opt sort)
+	 (opt flatten)))
+
+(define-structure compiler-test compiler-interface
+  (open scheme-level-2 syntactic scan-test meta-types
+	segments
+	reconstruction
+	packages
+	packages-internal       ;only for structure-package ?
+	interfaces		;interface-ref
+	locations		;make-undefined-location
+	architecture
+	enumerated		;enumerand->name
+	signals tables util fluids 
+	features)		;force-output
+  (files (bcomp comp)
+	 (bcomp cprim)
+	 (bcomp ctop)))
+
+(define-interface evaluation-test-interface
+  (export test-eval
+	  test-load
+	  test-load-into
+	  test-eval-from-file
+	  test-eval-scanned-forms))
+
+(define-structure evaluation-test evaluation-test-interface
+  (open scheme-level-2
+	compiler-test
+	packages			;package-uid
+	environments			;package-for-load
+	closures			;make-closure
+	vm-exposure			;invoke-closure
+	scan				;noting-undefined-variables
+	i/o				;current-noise-port
+	signals fluids)
+  (files (rts eval))
+  (begin
+    (define test-eval eval)
+    (define test-load load)
+    (define test-load-into load-into)
+    (define test-eval-from-file eval-from-file)
+    (define test-eval-scanned-forms eval-scanned-forms)))
+
diff --git a/scheme/vm/defdata.scm b/scheme/vm/defdata.scm
new file mode 100644
index 0000000..b0fe83f
--- /dev/null
+++ b/scheme/vm/defdata.scm
@@ -0,0 +1,146 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Macros for defining data types.
+
+; An ugly and unsafe macro for defining VM data structures.
+;
+; (DEFINE-PRIMITIVE-DATA-TYPE <name> <type> <immutable?> <constructor-name>
+;                             <slot>*)
+; <slot> ::= (<accessor-name>) | (<accessor-name> <modifier-name>)
+;
+; (define-primitive-data-type pair N #f cons (car set-car!) (cdr))
+; =>
+; (begin
+;  (define (cons a b) (d-vector N ...))
+;  (define pair? (stob-predicate ...))
+;  (define pair-size 3)
+;  (define (car x) (d-vector-ref x 0))
+;  (define (set-car! x val) (d-vector-set! x 0 val))
+;  (define (cdr x) (d-vector-ref x 1))
+
+(define-syntax define-primitive-data-type
+  (lambda (exp rename compare)
+    (destructure (((d-p-d-t name type immutable? make . body) exp))
+      (define (concatenate-symbol . syms)
+	(string->symbol (apply string-append (map symbol->string syms))))
+      (let* ((pred (concatenate-symbol name '?))
+	     (size (concatenate-symbol name '- 'size))
+	     (shorten (lambda (l1 l2) (map (lambda (x1 x2) x2 x1) l1 l2)))
+	     (vars (shorten `(a b c d e f g h i j) body)))
+	`(begin ,@(if make
+		      `((define ,make
+			  (let ((type (enum stob ,type)))
+			    (lambda (,@vars key)
+			      ,(if immutable?
+				   `(immutable-d-vector type key ,@vars)
+				   `(d-vector type key ,@vars))))))
+		      '())
+		(define ,pred (stob-predicate (enum stob ,type)))
+		(define ,size (+ ,(length body) stob-overhead))
+		,@(do ((s body (cdr s))
+		       (i 0 (+ i 1))
+		       (d '() (let* ((slot (car s))
+				     (d (cons `(define (,(car slot) x)
+						 (d-vector-ref x ,i))
+					      d)))
+				(if (null? (cdr slot))
+				    d
+				    (cons `(define (,(cadr slot) x val)
+					     (d-vector-set! x ,i val))
+					  d)))))
+		      ((null? s) (reverse d))))))))
+
+; This is a front for DEFINE-PRIMITIVE-DATA-TYPE that gets the names from
+; STOB-DATA (which is defined in arch.scm).  This ensures that the run-time
+; code, the VM, and the linker agree on what these structures look like.
+;
+; SCHEME? is #T if the data structure is a Scheme structure, in which case
+; the names defined by the form all have VM- prepended.
+
+(define-syntax define-shared-primitive-data-type
+  (lambda (exp rename compare)
+    (let* ((name (cadr exp))
+	   (scheme? (if (null? (cddr exp)) #f (car (cddr exp))))
+	   (immutable? (if (or (null? (cddr exp))
+			       (null? (cdddr exp)))
+			   #f
+			   (cadr (cddr exp))))
+	   (rest (if (or (null? (cddr exp))
+			 (null? (cdddr exp)))
+		     '()
+		     (cddddr exp)))
+	   (extra-maker (if (null? rest) #f (car rest)))
+	   (extra-setters (if (or (null? rest)
+				  (null? (cdr rest)))
+			      '()
+			      (cadr rest)))
+	   (extra-fields (if (or (null? rest)
+				 (null? (cdr rest)))
+			     '()
+			     (cddr rest))))
+      (define (concatenate-symbol . syms)
+	(string->symbol (apply string-append (map symbol->string syms))))
+      (let ((data (cddr (assq name stob-data)))
+	    (fixup (lambda (n)
+		     (if scheme? (concatenate-symbol 'vm- n) n))))
+	`(define-primitive-data-type
+	   ,(fixup name)
+	   ,name
+	   ,immutable?
+	   ,(fixup (if (car data) (car data) extra-maker))
+	   . ,(map (lambda (p)
+		     (cons (fixup (car p))
+			   (cond ((and (not (null? (cdr p)))
+				       (cadr p))
+				  (list (fixup (cadr p))))
+				 ((assq (car p) extra-setters)
+				  => cdr)
+				 (else '()))))
+		   (append (cdr data) extra-fields)))))))
+
+; A d-vector macro version of the VECTOR procedure.
+; This is only used in the expansion of DEFINE-PRIMITIVE-DATA-TYPE.
+
+(define-syntax d-vector
+  (lambda (exp rename compare)
+    (destructure (((d-v type key . args) exp))
+      `(let ((v (make-d-vector ,type ,(length args) key)))
+	 ,@(do ((a args (cdr a))
+		(i 0 (+ i 1))
+		(z '() (cons `(d-vector-init! v ,i ,(car a)) z)))
+	       ((null? a) (reverse z)))
+	 v))))
+
+(define-syntax immutable-d-vector
+  (syntax-rules ()
+   ((immutable-d-vector stuff ...)
+    (let ((vec (d-vector stuff ...)))
+      (make-immutable! vec)
+      vec))))
+
+; A simpler macro for defining types of vectors.  Again SCHEME? being #T
+; causes VM- to be prepended to the defined names.
+
+(define-syntax define-vector-data-type
+  (lambda (exp rename compare)
+    (let ((name (cadr exp))
+	  (scheme? (cddr exp)))
+      (define (concatenate-symbol . syms)
+	(string->symbol (apply string-append (map symbol->string syms))))
+      (let* ((type `(enum stob ,name))
+	     (fix (if (not (null? scheme?))
+		      'vm-
+		      (string->symbol "")))
+	     (pred (concatenate-symbol fix name '?))
+	     (make (concatenate-symbol fix 'make- name))
+	     (size (concatenate-symbol fix name '- 'size))
+	     (length (concatenate-symbol fix name '- 'length))
+	     (ref (concatenate-symbol fix name '- 'ref))
+	     (set (concatenate-symbol fix name '- 'set!)))
+	`(begin (define ,make (stob-maker ,type make-d-vector))
+		(define ,pred (stob-predicate ,type))
+		(define (,size len) (+ len stob-overhead))
+		(define ,length d-vector-length)
+		(define ,ref d-vector-ref)
+		(define ,set d-vector-set!))))))
diff --git a/scheme/vm/define-primitive.scm b/scheme/vm/define-primitive.scm
new file mode 100644
index 0000000..fa56d7f
--- /dev/null
+++ b/scheme/vm/define-primitive.scm
@@ -0,0 +1,138 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; These are hacked to ensure that all calls to INPUT-TYPE-PREDICATE and
+; INPUT-TYPE-COERCION are evaluated at load time (because they don't
+; have readily reconstructed types).
+
+(define-syntax define-primitive
+  (syntax-rules ()
+    ((define-primitive opcode input-types action)
+     (define-consing-primitive opcode input-types #f action))
+    ((define-primitive opcode input-types action returner)
+     (define-consing-primitive opcode input-types #f action returner))))
+
+(define-syntax define-consing-primitive
+  (syntax-rules ()
+    ((define-consing-primitive opcode input-types space-proc action)
+     (let ((proc (primitive-procedure-action input-types space-proc action)))
+       (define-opcode opcode (proc))))
+    ((define-consing-primitive opcode input-types space-proc action returner)
+     (let ((proc (primitive-procedure-action input-types space-proc action returner)))
+       (define-opcode opcode (proc))))))
+  
+(define-syntax primitive-procedure-action
+  (lambda (exp rename compare)
+    (destructure (((p-p-b input-types space-proc action . returner-option) exp))
+      (let* ((nargs (length input-types))
+	     (%action       (rename 'action))
+	     (%key          (rename 'key))
+	     (%ensure-space (rename 'ensure-space))
+	     (%*val*        (rename '*val*))
+	     (%arg2         (rename 'arg2))
+	     (%arg3         (rename 'arg3))
+	     (%arg4         (rename 'arg4))
+	     (%arg5         (rename 'arg5))
+	     (%pop          (rename 'pop))
+	     (%let          (rename 'let))
+	     (%let*         (rename 'let*))
+	     (%lambda       (rename 'lambda))
+	     (%if           (rename 'if))
+	     (%and          (rename 'and))
+	     (%goto         (rename 'goto))
+	     (%input-type-predicate (rename 'input-type-predicate))
+	     (%input-type-coercion  (rename 'input-type-coercion))
+	     (%raise-exception      (rename 'raise-exception))
+	     (%wrong-type-argument  (rename 'wrong-type-argument))
+	     (shorten (lambda (l1 l2)
+			(map (lambda (x1 x2) x2 x1) l1 l2)))
+	     (places (reverse (shorten (list %*val* %arg2 %arg3 %arg4 %arg5)
+				       input-types)))
+	     (preds (reverse (shorten (map rename
+					   '(pred1 pred2 pred3 pred4 pred5))
+				      input-types)))
+	     (x->ys (reverse (shorten (map rename
+					   '(x->y1 x->y2 x->y3 x->y4 x->y5))
+				      input-types))))
+	(if (> nargs 5)
+	    (error "time to add more arguments to DEFINE-PRIMITIVE"))
+	`(,%let (,@(map (lambda (type pred)
+			  `(,pred (,%input-type-predicate ,type)))
+			input-types
+			preds)
+		 ,@(map (lambda (type x->y)
+			  `(,x->y (,%input-type-coercion ,type)))
+			input-types
+			x->ys)
+		 (,%action ,action))
+	   (,%lambda ()
+	     (,%let* (,@(if space-proc
+			  `((,%key (,%ensure-space (,space-proc ,%*val*))))
+			  '())
+		    ,@(if (>= nargs 2) `((,%arg2 (,%pop))) `())
+		    ,@(if (>= nargs 3) `((,%arg3 (,%pop))) `())
+		    ,@(if (>= nargs 4) `((,%arg4 (,%pop))) `())
+		    ,@(if (>= nargs 5) `((,%arg5 (,%pop))) `())
+		    )
+	       (,%if (,%and ,@(map (lambda (pred place)
+				     `(,pred ,place))
+				   preds
+				   places))
+		     ,(let ((yow `(,%action
+				   ,@(map (lambda (x->y place)
+					    `(,x->y ,place))
+					  x->ys
+					  places)
+				   ,@(if space-proc `(,%key) '()))))
+			(if (null? returner-option)
+			    yow
+			    `(,%goto ,(car returner-option) ,yow)))
+		     (,%raise-exception ,%wrong-type-argument
+					0
+					. ,places)))))))))
+
+;----------------
+; Checking inputs and coercing results
+
+(define (input-type pred coercer)  ;Alonzo wins
+  (lambda (f) (f pred coercer)))
+
+(define (input-type-predicate type) (type (lambda (x y) y x)))
+(define (input-type-coercion type)  (type (lambda (x y) x y)))
+
+(define (no-coercion x) x)
+
+(define any->         (input-type (lambda (x) x #t) no-coercion))
+(define fixnum->      (input-type fixnum?      extract-fixnum))
+(define char->        (input-type vm-char?     extract-char))
+(define vm-char->     (input-type vm-char?     no-coercion))
+(define boolean->     (input-type vm-boolean?  extract-boolean))
+(define location->    (input-type location?    no-coercion))
+(define string->      (input-type vm-string?   no-coercion))
+(define vector->      (input-type vm-vector?   no-coercion))
+(define code-vector-> (input-type code-vector? no-coercion))
+
+; Output coercion
+
+(define (return val)
+  (set! *val* val)
+  (goto continue 0))
+
+(define return-any return)
+
+(define (return-boolean x)
+  (goto return (enter-boolean x)))
+
+(define (return-fixnum x)
+  (goto return (enter-fixnum x)))
+
+(define (return-char x)
+  (goto return (enter-char x)))
+
+(define (return-unspecific x)
+  x ;ignored
+  (goto return unspecific-value))
+
+(define (no-result)
+  (goto return unspecific-value))
+
diff --git a/scheme/vm/disasm.scm b/scheme/vm/disasm.scm
new file mode 100644
index 0000000..88adc90
--- /dev/null
+++ b/scheme/vm/disasm.scm
@@ -0,0 +1,164 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Disassembler that uses the VM's data structures.
+
+(define (disassemble stuff . no-subtemplates)
+  (let ((template (cond ((template? stuff) stuff)
+			((closure? stuff) (closure-template stuff))
+			((and (location? stuff)
+			      (closure? (contents stuff)))
+			 (closure-template (contents stuff)))
+			(else
+			 (error "cannot coerce to template" stuff)))))
+    (really-disassemble template
+			0
+			(if (null? no-subtemplates)
+			    #f
+			    (car no-subtemplates)))
+    (newline)))
+
+(define (really-disassemble tem level write-templates?)
+  (let loop ((pc 0))
+    (if (< pc (code-vector-length (template-code tem)))
+        (loop (write-instruction tem pc level write-templates?)))))
+
+(define (newline-indent n)
+  (newline)
+  (do ((i n (- i 1)))
+      ((= i 0))
+    (display #\space)))
+
+(define (write-pc pc)
+  (if (< pc 100) (display " "))
+  (if (< pc 10) (display " "))
+  (write pc))
+
+(define (write-instruction template pc level write-sub-templates?)
+  (let* ((code (template-code template))
+         (opcode (code-vector-ref code pc)))
+    (newline-indent (* level 3))
+    (write-pc pc)
+    (display " (")
+    (write (enumerand->name opcode op))
+    (let ((pc (cond ((= opcode (enum op computed-goto))
+ 		     (display-computed-goto pc code))
+ 		    ((= opcode (enum op make-flat-env))
+ 		     (display-flat-env (+ pc 1) code))
+		    ((= opcode (enum op protocol))
+		     (display-protocol pc code))
+ 		    (else
+ 		     (print-opcode-args opcode (+ pc 1) code template
+ 					level write-sub-templates?)))))
+      (display #\))
+      pc)))
+
+(define (display-computed-goto start-pc code)
+  (display #\space)
+  (let ((count (code-vector-ref code (+ start-pc 1))))
+    (write count)
+    (do ((pc (+ start-pc 2) (+ pc 2))
+	 (count count (- count 1)))
+	((= count 0) pc)
+      (display #\space)
+      (write `(=> ,(+ start-pc (get-offset pc code)))))))
+
+(define (display-flat-env pc code)
+  (let ((total-count (code-vector-ref code (+ pc 1))))
+    (display #\space) (write total-count)
+    (let loop ((pc (+ pc 2)) (count 0) (old-back 0))
+      (if (= count total-count)
+	  pc
+	  (let ((back (+ (code-vector-ref code pc)
+			 old-back))
+		(limit (+ pc 2 (code-vector-ref code (+ pc 1)))))
+	    (do ((pc (+ pc 2) (+ pc 1))
+		 (count count (+ count 1))
+		 (offsets '() (cons (code-vector-ref code pc) offsets)))
+		((= pc limit)
+		 (display #\space)
+		 (write `(,back ,(reverse offsets)))
+		 (loop pc count back))))))))
+
+(define (display-protocol pc code)
+  (let ((protocol (code-vector-ref code (+ pc 1))))
+    (display #\space)
+    (+ pc (cond ((<= protocol maximum-stack-args)
+		 (display protocol)
+		 2)
+		((= protocol two-byte-nargs-protocol)
+		 (display (get-offset (+ pc 2) code))
+		 4)
+		((= protocol two-byte-nargs+list-protocol)
+		 (display (get-offset (+ pc 2) code))
+		 (display "+")
+		 4)
+		((= protocol args+nargs-protocol)
+		 (display "args+nargs")
+		 3)
+		((= protocol nary-dispatch-protocol)
+		 (display "nary-dispatch")
+		 (do ((i 0 (+ i 1)))
+		     ((= i 4))
+		   (let ((offset (code-vector-ref code (+ pc 2 i))))
+		     (if (not (= offset 0))
+			 (begin
+			   (display #\space)
+			   (display (list (if (= i 3) "3+" i)
+					  '=>
+					  (+ pc offset)))))))
+		 6)
+		(else
+		 (error "unknown protocol" protocol))))))
+
+(define (print-opcode-args op pc code template level write-templates?)
+  (let ((specs (vector-ref opcode-arg-specs op)))
+    (let loop ((specs specs) (pc pc))
+      (cond ((or (null? specs)
+		 (= 0 (arg-spec-size (car specs))))
+	     pc)
+	    (else
+	     (display #\space)
+	     (print-opcode-arg specs pc code template level write-templates?)
+	     (loop (cdr specs) (+ pc (arg-spec-size (car specs)))))))))
+
+(define (arg-spec-size spec)
+  (case spec
+    ((nargs byte stob junk) 1)
+    ((offset small-index index two-bytes) 2)
+    (else 0)))
+
+(define (print-opcode-arg specs pc code template level write-templates?)
+  (case (car specs)
+    ((nargs byte)
+     (write (code-vector-ref code pc)))
+    ((two-bytes)
+     (write (get-offset pc code)))
+    ((index)
+     (let ((thing (template-ref template (get-offset pc code))))
+       (write-literal-thing thing level write-templates?)))
+    ((small-index)
+     (let ((thing (template-ref template (code-vector-ref code pc))))
+       (write-literal-thing thing level write-templates?)))
+    ((offset)
+     (write `(=> ,(+ pc -1 (get-offset pc code)))))  ; -1 to back up over opcode
+    ((stob)
+     (write (enumerand->name (code-vector-ref code pc) stob)))))
+
+(define (get-offset pc code)
+  (+ (* (code-vector-ref code pc)
+	byte-limit)
+     (code-vector-ref code (+ pc 1))))
+
+(define (write-literal-thing thing level write-templates?)
+  (cond ((location? thing)
+	 (write `(location ,thing ,(location-id thing))))
+	((not (template? thing))
+	 (display #\')
+	 (write thing))
+	(write-templates?
+	 (really-disassemble thing (+ level 1) #t))
+	(else
+	 (display "..."))))
+
+
diff --git a/scheme/vm/env.scm b/scheme/vm/env.scm
new file mode 100644
index 0000000..e8ffce4
--- /dev/null
+++ b/scheme/vm/env.scm
@@ -0,0 +1,98 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+(define *env*)
+
+(define (current-env) *env*)
+(define (set-current-env! env) (set! *env* env))
+
+; Access to environment slots
+
+(define env-ref  vm-vector-ref)
+(define env-set! vm-vector-set!)
+(define (env-parent env) (env-ref env 0))
+(define (set-env-parent! env x) (env-set! env 0 x))
+
+(define (env-back env back)  ;Resembles NTHCDR
+  (do ((env env (env-parent env))
+       (i back (- i 1)))
+      ((= i 0) env)))
+
+; Making new environments
+
+(define (pop-args-into-env count)
+  (push *env*)
+  (push (make-header (enum stob vector) (cells->bytes (+ count 1))))
+  (add-env-stats count)
+  (set! *env* (address->stob-descriptor (address2+ *stack*))))
+
+; Alternative method for making environments - put the values into the heap.
+
+(define (heap-env-space count)
+  (+ stob-overhead (+ count 1)))  ; includes superior environment
+
+(define (pop-args-into-heap-env count key)
+  (let ((stob (make-d-vector (enum stob vector) (+ count 1) key)))
+    (copy-memory! (address1+ *stack*)
+		  (address+ (address-after-header stob)
+			    (cells->a-units 1))
+		  (cells->bytes count))
+    (add-cells-to-stack! (- 0 count))
+    (vm-vector-set! stob 0 *env*)
+    (set! *env* stob)))
+
+; Migrate the current environment to the heap.  Used when creating a closure.
+; CURRENT-ENV-SIZE size is conservative.
+
+(define (current-env-size)
+  (if (within-stack? *env*)
+      (stack-size)
+      0))
+
+; This is what the interpreter calls when it needs to put the current
+; environment in a closure.
+
+(define (preserve-current-env key)
+  (preserve-current-env-with-reason key (enum copy closure)))
+
+(define (preserve-current-env-with-reason key reason)
+  (if (within-stack? *env*)
+      (set! *env* (save-env-in-heap *env* *cont* key reason)))
+  *env*)
+
+; 1) Copy ENV and its ancestors into heap, adding forwarding pointers
+; 2) Go down the continuation chain updating the env pointers
+;
+; This code depends on continuation-cont pointers not crossing environment
+; parent pointers on the stack.
+
+(define (save-env-in-heap env cont key reason)
+  (let ((top (copy-env env key reason)))
+    (let loop ((env top))
+      (cond ((within-stack? (env-parent env))
+             (let ((new (copy-env (env-parent env) key reason)))
+               (set-env-parent! env new)
+               (loop new)))))
+    (let loop ((cont cont))
+      (let ((env (continuation-env cont)))
+        (cond ((and (stob? env)
+                    (stob? (stob-header env)))
+               (set-continuation-env! cont (stob-header env))
+               (loop (continuation-cont cont))))))
+    top))
+
+; ARGUMENTS-ON-STACK needs to walk down the stack and find the end of the
+; current arguments.  It looks for headers, which we clobber with forwarding
+; pointers, so we put a marker in the first slot of the environment and
+; ARGUMENTS-ON-STACK knows to back up one if it finds the marker.
+; (Putting the forwarding pointer in the first slot doesn't work, because
+;  we can't distinguish between it and a normal first slot.)
+
+(define (copy-env env key reason)
+  (let ((new (header+contents->stob (stob-header env)
+				    (address-after-header env)
+				    key)))
+    (add-copy-env-stats env reason)
+    (vm-vector-set! env 0 argument-limit-marker)
+    (stob-header-set! env new)
+    new))
diff --git a/scheme/vm/error-util.scm b/scheme/vm/error-util.scm
new file mode 100644
index 0000000..61aa2e8
--- /dev/null
+++ b/scheme/vm/error-util.scm
@@ -0,0 +1,13 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+(define (error? status)
+  (not (eq? status (enum errors no-errors))))
+
+(define (write-error-string string)
+  (write-string string (current-error-port)))
+
+(define (write-error-integer integer)
+  (write-integer integer (current-error-port)))
+
+(define (error-newline)
+  (write-char #\newline (current-error-port)))
diff --git a/scheme/vm/external-call.scm b/scheme/vm/external-call.scm
new file mode 100644
index 0000000..ad51421
--- /dev/null
+++ b/scheme/vm/external-call.scm
@@ -0,0 +1,215 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Calling C procedures.
+
+; The arguments have been pushed on the stack after the procedure.
+; *stack* = procedure name arg1 ... argN rest-list N+1 total-nargs
+;
+; The procedure must be an external binding whose value is a pointer-sized
+; code-vector.  If it is, we actually do the call.
+
+(define-primitive call-external-value ()
+  (lambda ()
+    (let* ((nargs (extract-fixnum (pop)))
+	   (stack-nargs (extract-fixnum (pop)))
+	   (rest-list (pop)))
+      (if (< maximum-external-call-args
+	     nargs)
+	  (raise-exception too-many-arguments-to-external-procedure
+			   (stack-ref (- stack-nargs 1))
+			   nargs)
+	  (begin
+	    (do ((rest-list rest-list (vm-cdr rest-list)))
+		((vm-eq? rest-list null))
+	      (push (vm-car rest-list)))
+	    (let ((proc (stack-ref (- nargs 1)))
+		  (name (stack-ref (- nargs 2)))
+		  (args (pointer-to-stack-arguments)))
+	      ; Push a header to keep the arguments from being scanned.
+	      (push (make-header (enum stob vector)
+				 (cells->bytes nargs)))
+	      (if (and (vm-string? name)
+		       (code-vector? proc)
+		       (= (code-vector-length proc)
+			  (cells->bytes 1)))
+		  (let ((result (external-call proc name (- nargs 2) args)))
+		    (cond (*external-exception?*
+			   (set! *external-exception?* #f)
+			   (goto raise *external-exception-nargs*))
+			  (else
+			   (goto continue-with-value result 0))))
+		  (raise-exception wrong-type-argument 0 proc name))))))))
+
+;----------------
+; Raising exceptions from C.
+
+; True if the C procedure is raising an exception instead of doing a normal
+; return.
+
+(define *external-exception?* #f)
+
+; The number of arguments being passed to the exception handler.
+
+(define *external-exception-nargs*)
+
+; These are for exceptions raised by external code.  They work pretty
+; much in the same way as other VM instructions raise exceptions.
+; Note that this doesn't actually perform the raise; it just sets
+; *EXTERNAL-EXCEPTION?* to be true, so that the EXTERNAL-CALL procedure
+; will do the raise.
+;
+; If you extend the maximum number of arguments, be sure to adjust the
+; definition of STACK-SLACK in stack.scm.  It needs to know the maximum
+; number of values pushed by an exception handler, which is the number
+; of arguments pushed here, plus the procedure.
+
+(define (s48-setup-external-exception why nargs)
+  (push-exception-continuation! why 1)		; 1 = one-byte instruction
+  (if (< 10 nargs)
+      (error "too many arguments from external exception"))
+  (set! *external-exception-nargs* nargs)
+  (set! *external-exception?* #t))
+
+; The external code needs to piggyback an exception on top of one already
+; being raised.  We increase the argument count and return the old exception.
+
+(define (s48-resetup-external-exception new-why additional-nargs)
+  (let* ((old-nargs *external-exception-nargs*)
+	 (old-why (stack-ref old-nargs)))
+    (stack-set! old-nargs (enter-fixnum new-why))
+    (set! *external-exception-nargs* (+ old-nargs additional-nargs))
+    old-why))
+
+;----------------
+; Two tables of shared bindings: those we import from the outside and those
+; that we provide to the outside.
+
+(define *imported-bindings*)
+(define *exported-bindings*)
+
+; When resuming a statically-linked image these tables are FALSE.
+
+(define (install-shared-bindings!+gc imported-bindings exported-bindings)
+  (receive (key imported-bindings exported-bindings)
+      (ensure-space-saving-temps (* hash-table-size 2)
+				 imported-bindings
+				 exported-bindings)
+    (set! *imported-bindings*
+	  (if (vm-eq? imported-bindings false)
+	      (make-hash-table key)
+	      imported-bindings))
+    (set! *exported-bindings*
+	  (if (vm-eq? exported-bindings false)
+	      (make-hash-table key)
+	      exported-bindings))))
+
+(define shared-binding-table-size
+  (* hash-table-size 2))
+
+(add-gc-root!
+  (lambda ()
+    (set! *imported-bindings* (s48-trace-value *imported-bindings*))
+    (set! *exported-bindings* (s48-trace-value *exported-bindings*))))
+
+; These next two procedure are used to write the bindings tables out in images.
+
+(define (s48-exported-bindings)
+  *exported-bindings*)
+
+; This returns a version of the import table that contains only those bindings
+; that have been traced, and in which the values of the bindings are all set to
+; UNASSIGNED-VALUE.
+
+(define s48-cleaned-imported-bindings
+  (let ((cleaner (table-cleaner shared-binding-next set-shared-binding-next!))
+	(walker (table-walker shared-binding-next)))
+    (lambda ()
+      (let ((table (s48-trace-value *imported-bindings*)))
+	(cleaner table)
+	(walker (lambda (binding)
+		  (shared-binding-set! binding unassigned-marker))
+		table)
+	table))))
+
+; Imported bindings.
+
+(define lookup-imported-binding
+  (let* ((maker (lambda (string next key)
+		  (make-shared-binding string true unspecific-value next key)))
+	 (lookup (table-searcher shared-binding-name
+				 shared-binding-next
+				 maker)))
+    (lambda (name key)
+      (lookup *imported-bindings* name key))))
+    
+; Exporting bindings.
+
+(define lookup-exported-binding
+  (let* ((maker (lambda (string next key)
+		  (make-shared-binding string false unspecific-value next key)))
+	 (lookup (table-searcher shared-binding-name
+				 shared-binding-next
+				 maker)))
+    (lambda (name key)
+      (lookup *exported-bindings* name key))))
+
+; Print warnings about all imported bindings which the external code
+; has not yet defined.
+
+(define s48-warn-about-undefined-imported-bindings
+  (let ((walker (table-walker shared-binding-next)))
+    (lambda ()
+      (let ((out (current-error-port)))
+	(walker (lambda (binding)
+		  (if (undefined? (shared-binding-ref binding))
+		      (let ((name (shared-binding-name binding)))
+			(write-string "undefined imported name " out)
+			(if (vm-string? name)
+			    (write-string (extract-string name) out)
+			    (write-string "<invalid name>" out))
+			(write-char #\newline out))))
+		*imported-bindings*)))))
+
+;----------------
+; Four primitives for adding and removing imports and exports.
+
+(define-consing-primitive lookup-shared-binding (string-> boolean->)
+  (lambda (ignore)
+    shared-binding-size)
+  (lambda (name is-import? key)
+    (goto return
+	  (if is-import?
+	      (lookup-imported-binding name key)
+	      (lookup-exported-binding name key)))))
+
+(define undefine-shared-binding!
+  (table-remover shared-binding-name
+		 shared-binding-next
+		 set-shared-binding-next!))
+
+(define-primitive undefine-shared-binding (string-> boolean->)
+  (lambda (name is-import?)
+    (undefine-shared-binding! (if is-import?
+				  *imported-bindings*
+				  *exported-bindings*)
+			      name)
+    (goto continue 0)))
+
+;----------------
+; The following two functions are exported to C, hence the reversal of the
+; export/import terminology.
+
+(define (s48-define-exported-binding name value)
+  (receive (key value)
+      (ensure-space-saving-temp (+ shared-binding-size
+				   (vm-string-size (string-length name)))
+				value)
+    (shared-binding-set! (lookup-imported-binding (enter-string name key) key)
+			 value)))
+
+(define (s48-get-imported-binding name)
+  (let ((key (ensure-space (+ shared-binding-size
+			      (vm-string-size (string-length name))))))
+    (lookup-exported-binding (enter-string name key) key)))
+
diff --git a/scheme/vm/external.scm b/scheme/vm/external.scm
new file mode 100644
index 0000000..9fa2e64
--- /dev/null
+++ b/scheme/vm/external.scm
@@ -0,0 +1,18 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+(define (fake-it name)
+  (lambda args
+    (display "Call to ")
+    (display (cons name args))
+    (newline)
+    0))
+
+(define extended-vm        (fake-it 'extended-vm))
+(define external-call      (fake-it 'call-external-value))
+(define schedule-interrupt (fake-it 'schedule-interrupt))
+
+(define (real-time) 0)
+(define (run-time) 0)
+(define (cheap-time) 0)
+
diff --git a/scheme/vm/fixnum-op.scm b/scheme/vm/fixnum-op.scm
new file mode 100644
index 0000000..c68444b
--- /dev/null
+++ b/scheme/vm/fixnum-op.scm
@@ -0,0 +1,140 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Fixnum-only primitive operations
+
+; These predicates are used to characterize the numeric representations that
+; are implemented in the VM.
+
+(define (unary-lose x)
+  (raise-exception wrong-type-argument 0 x))
+
+(define (binary-lose x y)
+  (raise-exception wrong-type-argument 0 x y))
+
+(define-primitive number? (any->)
+  (lambda (x)
+    (or (fixnum? x)
+	(bignum? x)
+	(ratnum? x)
+	(double? x)
+	(extended-number? x)))
+  return-boolean)
+  
+(define (vm-number-predicate rationals? doubles?)
+  (lambda (n)
+    (cond ((or (fixnum? n)
+	       (bignum? n)
+	       (and rationals? (ratnum? n))
+	       (and doubles? (double? n)))
+	   (goto return-boolean #t))
+	  ((extended-number? n)
+	   (unary-lose n))
+	  (else
+	   (goto return-boolean #f)))))
+
+(define-primitive integer?  (any->) (vm-number-predicate #f #f))
+(define-primitive rational? (any->) (vm-number-predicate #t #t))
+(define-primitive real?     (any->) (vm-number-predicate #t #t))
+(define-primitive complex?  (any->) (vm-number-predicate #t #t))
+
+;----------------
+; A macro for defining primitives that only operate on fixnums.
+
+(define-syntax define-fixnum-only
+  (syntax-rules ()
+    ((define-fixnum-only (opcode arg) value)
+     (define-primitive opcode (any->)
+       (lambda (arg)
+	 (if (fixnum? arg)
+	     (goto return value)
+	     (unary-lose arg)))))
+    ((define-fixnum-only (opcode arg0 arg1) value)
+     (define-primitive opcode (any-> any->)
+       (lambda (arg0 arg1)
+	 (if (and (fixnum? arg0)
+		  (fixnum? arg1))
+	     (goto return value)
+	     (binary-lose arg0 arg1)))))))
+
+; These primitives have a simple answer in the case of fixnums; for all others
+; they punt to the run-time system.
+
+(define-fixnum-only (exact?      n) true)
+(define-fixnum-only (real-part   n) n)
+(define-fixnum-only (imag-part   n) (enter-fixnum 0))
+(define-fixnum-only (floor       n) n)
+(define-fixnum-only (numerator   n) n)
+(define-fixnum-only (denominator n) (enter-fixnum 1))
+
+(define-primitive angle (any->)
+  (lambda (n)
+    (if (and (fixnum? n)
+	     (>= n 0))
+	(goto return (enter-fixnum 0))
+	(unary-lose n))))
+
+(define-primitive magnitude (any->)
+  (lambda (n)
+    (if (fixnum? n)
+	(abs-carefully n
+		       (lambda (r)
+			 (goto return r))
+		       unary-lose)
+	(unary-lose n))))
+
+; These all just raise an exception and let the run-time system do the work.
+
+(define-syntax define-punter
+  (syntax-rules ()
+    ((define-punter opcode)
+     (define-primitive opcode (any->) unary-lose))))
+
+(define-punter exact->inexact)
+(define-punter inexact->exact)
+(define-punter exp)
+(define-punter log)
+(define-punter sin)
+(define-punter cos)
+(define-punter tan)
+(define-punter asin)
+(define-punter acos)
+(define-punter sqrt)
+
+(define-syntax define-punter2
+  (syntax-rules ()
+    ((define-punter2 opcode)
+     (define-primitive opcode (any-> any->) binary-lose))))
+
+(define-punter2 atan)
+(define-punter2 make-polar)
+(define-punter2 make-rectangular)
+
+(define-syntax define-binop
+  (syntax-rules ()
+    ((define-binop opcode careful-op)
+     (define-primitive opcode (any-> any->)
+       (lambda (x y)
+	 (if (and (fixnum? x)
+		  (fixnum? y))
+	     (goto careful-op x y return binary-lose)
+	     (binary-lose x y)))))))
+
+(define-binop + add-carefully)
+(define-binop - subtract-carefully)
+(define-binop * multiply-carefully)
+(define-binop / divide-carefully)
+(define-binop quotient         quotient-carefully)
+(define-binop remainder        remainder-carefully)
+(define-binop arithmetic-shift shift-carefully)
+
+(define-fixnum-only (=  x y) (enter-boolean (fixnum=  x y)))
+(define-fixnum-only (<  x y) (enter-boolean (fixnum<  x y)))
+(define-fixnum-only (>  x y) (enter-boolean (fixnum>  x y)))
+(define-fixnum-only (<= x y) (enter-boolean (fixnum<= x y)))
+(define-fixnum-only (>= x y) (enter-boolean (fixnum>= x y)))
+
+(define-fixnum-only (bitwise-not x)   (fixnum-bitwise-not x))
+(define-fixnum-only (bitwise-and x y) (fixnum-bitwise-and x y))
+(define-fixnum-only (bitwise-ior x y) (fixnum-bitwise-ior x y))
+(define-fixnum-only (bitwise-xor x y) (fixnum-bitwise-xor x y))
diff --git a/scheme/vm/gc-package-defs.scm b/scheme/vm/gc-package-defs.scm
new file mode 100644
index 0000000..0d2f661
--- /dev/null
+++ b/scheme/vm/gc-package-defs.scm
@@ -0,0 +1,30 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; These are used to compile the GC separately from the VM.  It has new
+; definitions of the VM structures that the GC uses, with all of the values
+; defined as externals.  We only need to define those values that the GC
+; actually uses.
+
+; These are all called when writing images.
+
+(define-structure symbols (export s48-copy-symbol-table)
+  (open prescheme)
+  (begin
+    (define s48-copy-symbol-table
+      (external "s48_copy_symbol_table" (=> () integer)))))
+
+(define-structure vmio (export s48-mark-traced-channels-closed!)
+  (open prescheme)
+  (begin
+    (define s48-mark-traced-channels-closed!
+      (external "s48_mark_traced_channels_closedB" (=> () null)))))
+
+(define-structure external-opcodes (export s48-cleaned-imported-bindings
+					   s48-exported-bindings)
+  (open prescheme)
+  (begin
+    (define s48-cleaned-imported-bindings
+      (external "s48_cleaned_imported_bindings" (=> () integer)))
+    (define s48-exported-bindings
+      (external "s48_exported_bindings" (=> () integer)))))
diff --git a/scheme/vm/gc-root.scm b/scheme/vm/gc-root.scm
new file mode 100644
index 0000000..591fc06
--- /dev/null
+++ b/scheme/vm/gc-root.scm
@@ -0,0 +1,134 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; This manages external roots that can be registered and unregistered in a
+; stack-like fashion.  It also provides the GC interface for the C FFI.
+
+;----------------
+; Stack of external roots implemented as a list.
+
+(define *external-root-stack* null-address)
+
+(define *external-root-stack-base* null-address)
+
+; Format of a roots frame:
+; 0: number of addresses in the frame, n
+;    This may be negative---the frame then serves as a marker.
+; 1: address of previous frame
+; 2: location address of object 0
+; 3: location address of object 1
+; ...
+; n+1: location address of object n-1
+
+(define (frame-next frame)
+  (fetch-address (address1+ frame)))
+
+(define (frame-length frame)
+  (fetch frame))
+
+(define (frame-ref frame index)
+  (fetch-address (address+ frame (cells->a-units (+ index 2)))))
+
+; Fetch an address.
+
+(define (fetch-address address)
+  (integer->address (fetch address)))
+
+;----------------
+; Pushing and popping frames
+
+; You call this with the number of roots to be registered and a frame
+; which must contain space for n+2 pointers.
+
+(define (s48-push-gc-roots! frame n)
+  (store! frame n)
+  (store! (address1+ frame)
+	  (address->integer *external-root-stack*))
+  (set! *external-root-stack* frame))
+
+; We aren't allowed to pop past the current base.
+
+(define (s48-pop-gc-roots!)
+  (if (address= *external-root-stack* *external-root-stack-base*)
+      #f
+      (begin
+	(set! *external-root-stack* (frame-next *external-root-stack*))
+	#t)))
+
+; We set the base before we jump to a C procedure from Scheme.  When it returns
+; we check that everything that was pushed has been popped.  The caller saves
+; the old base for us.
+
+(define (s48-set-gc-roots-base!)
+  (let ((old-base *external-root-stack-base*))
+    (set! *external-root-stack-base* *external-root-stack*)
+    old-base))
+
+(define (s48-release-gc-roots-base! old-base)
+  (let ((okay? (address= *external-root-stack*
+			 *external-root-stack-base*)))
+    (set! *external-root-stack-base* old-base)
+    okay?))
+
+;----------------
+; This is for permanent roots, such as external global variables.
+; We keep these in a simple list.
+
+(define *permanent-external-roots* null-address)
+
+(define (s48-register-gc-root! loc-addr)
+  (let ((frame (allocate-memory (cells->bytes 2))))
+    (if (null-address? frame)
+	(error "out of memory registering a global root"))
+    (store! frame (address->integer *permanent-external-roots*))
+    (store! (address1+ frame) (address->integer loc-addr))
+    (set! *permanent-external-roots* frame)))
+
+(define (permanent-root-pointer address)
+  (fetch-address (address1+ address)))
+
+(define (permanent-root-next address)
+  (fetch-address address))
+
+; This is exported and used to (attempt to) recover from user errors.
+
+(define (s48-set-gc-roots-marker! marker)
+  (set! *external-root-stack* marker))
+
+;----------------
+; Tracing
+;
+; We just walk down each list.
+
+(add-gc-root!
+  (lambda () 
+    (trace-external-root-stack)
+    (trace-permanent-external-roots)))
+
+(define (trace-external-root-stack)
+  (let loop ((frame *external-root-stack*))
+    (if (not (null-address? frame))
+	(let ((length (frame-length frame)))
+	  (do ((i 0 (+ i 1)))
+	      ((= i length))
+	    (trace-cell (frame-ref frame i))) 
+	  (loop (frame-next frame))))))
+
+(define (trace-permanent-external-roots)
+  (let loop ((frame *permanent-external-roots*))
+    (if (not (null-address? frame))
+	(begin
+	  (trace-cell (permanent-root-pointer frame))
+	  (loop (permanent-root-next frame))))))
+
+; Trace the contents of a cell.
+
+(define (trace-cell cell)
+  (store! cell (s48-trace-value (fetch cell))))
+
+;----------------
+; The point to all this is, in part, to be able to allocate space while
+; outside the VM.
+
+(define (s48-allocate-stob type size)
+  (make-b-vector type size (ensure-space size)))
diff --git a/scheme/vm/gc.scm b/scheme/vm/gc.scm
new file mode 100644
index 0000000..3ef757f
--- /dev/null
+++ b/scheme/vm/gc.scm
@@ -0,0 +1,325 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Collector
+
+; The interface to the GC consists of
+; (S48-BEGIN-COLLECTION)		; call either this
+; (BEGIN-WRITING-IMAGE)			; or this first
+; (S48-TRACE-LOCATIONS! start end)	; trace all roots
+; (S48-TRACE-VALUE value) => copied value
+; (S48-TRACE-STOB-CONTENTS! stob)
+; (S48-DO-GC)				; then do the GC
+; (S48-END-COLLECTION)			; and either finish
+; (ABORT-COLLECTION)			; or abort if writing an image
+
+(define *gc-count* 0)
+(define (s48-gc-count) *gc-count*)
+
+; True if the GC is being done for the purpose of dumping an image, in which
+; case we check for undumpable records.
+
+(define *writing-image?*)
+(define *undumpable-records*)
+(define *undumpable-count*)
+
+(define (s48-begin-collection)
+  (really-begin-collection)
+  (set! *writing-image?* #f)
+  (trace-static-areas)
+  (unspecific))
+
+(define (begin-writing-image)
+  (really-begin-collection)
+  (set! *writing-image?* #t)
+  (set! *undumpable-records* null)
+  (set! *undumpable-count* 0))
+
+(define (really-begin-collection)
+  (set! *from-begin* (heap-start))
+  (set! *from-end* (heap-limit))
+  (swap-spaces)
+  (set-heap-pointer! (heap-start))
+  (set! *weak-pointer-hp* null-address))
+
+(define *from-begin*)
+(define *from-end*)
+
+(define (in-oldspace? descriptor)
+  (and (stob? descriptor)
+       (let ((a (address-after-header descriptor)))
+         (and (address>= a *from-begin*)
+              (address< a *from-end*)))))
+
+(define (s48-trace-value stob)
+  (cond ((and *writing-image?*
+	      (undumpable? stob))
+	 (begin
+	   (note-undumpable! stob)
+	   (s48-trace-value (undumpable-alias stob))))
+	((in-oldspace? stob)
+	 (copy-object stob))
+	(else
+	 stob)))
+    
+(define (s48-end-collection)
+  (set! *gc-count* (+ *gc-count* 1)))
+
+(define (s48-undumpable-records)
+  (values *undumpable-records*
+	  *undumpable-count*))
+
+; Undo the effects of the current collection (assuming that it did not
+; modify any VM registers or the stack).
+
+(define (abort-collection)
+  (swap-spaces)
+  (let loop ((addr (heap-start)))
+    (if (address< addr (heap-pointer))
+	(let* ((d (fetch addr))
+	       (h (if (header? d)
+		      d
+		      (let ((h (stob-header d)))
+			(store! addr h)            ; mend heart
+			h))))
+	  (loop (address+ addr
+			  (+ (cells->a-units stob-overhead)
+			     (header-length-in-a-units h))))))))
+
+; Complete a GC after all roots have been traced.
+
+(define (trace-static-areas)
+  (walk-impure-areas
+   (lambda (start end)
+     (s48-trace-locations! start end)
+     #t)))
+
+; Scan the heap, copying pointed to objects, starting from START.  Quit once
+; the scanning pointer catches up with the heap pointer.
+
+(define (s48-do-gc)
+  (let loop ((start (heap-start)))
+    (let ((end (heap-pointer)))
+      (s48-trace-locations! start end)
+      (cond ((< (s48-available) 0)
+	     (error "GC error: ran out of space in new heap"))
+	    ((address< end (heap-pointer))
+	     (loop end)))))
+  (clean-weak-pointers))
+
+(define (s48-trace-stob-contents! stob)
+  (let ((start (address-after-header stob))
+	(size (bytes->a-units (header-length-in-bytes (stob-header stob)))))
+    (s48-trace-locations! start (address+ start size))))
+
+; Copy everything pointed to from somewhere between START (inclusive)
+; and END (exclusive).
+
+(define (s48-trace-locations! start end)
+  (let loop ((addr start) (frontier (heap-pointer)))
+    (if (address< addr end)
+	(let ((thing (fetch addr))
+	      (next (address1+ addr)))
+	  (cond ((header? thing)
+		 (cond ((b-vector-header? thing)
+			(loop (address+ next (header-length-in-a-units thing))
+			      frontier))
+		       (else
+			(loop next frontier))))
+		((and *writing-image?*
+		      (undumpable? thing))
+		 (note-undumpable! thing)
+		 (store! addr (undumpable-alias thing))
+		 (loop addr frontier))
+		((in-oldspace? thing)
+		 (receive (new-thing frontier)
+		     (real-copy-object thing frontier)
+		   (store! addr new-thing)
+		   (loop next frontier)))
+		(else
+		 (loop next frontier))))
+	(set-heap-pointer! frontier)))
+  0)  ; for the type-checker
+
+; Copy THING if it has not already been copied.
+
+(define (copy-object thing)
+  (receive (new-thing new-hp)
+      (real-copy-object thing (heap-pointer))
+    (set-heap-pointer! new-hp)
+    new-thing))
+
+; Non-heap-pointer version for better code in TRACE-LOCATIONS
+
+(define (real-copy-object thing frontier)
+  (let ((h (stob-header thing)))
+    (cond ((stob? h)            ;***Broken heart
+	   ;; (assert (in-newspace? h))
+	   (values h frontier))
+	  ((and (vm-eq? weak-pointer-header h)
+		(in-oldspace? (fetch (address-after-header thing))))
+	   (copy-weak-pointer thing frontier))
+	  (else
+	   (store! frontier h)
+	   (let* ((data-addr (address+ frontier (cells->a-units stob-overhead)))
+		  (new (address->stob-descriptor data-addr)))
+	     (stob-header-set! thing new) ;***Break heart
+	     (copy-memory! (address-after-header thing)
+			   data-addr
+			   (header-length-in-bytes h))
+	     (values new
+		     (address+ data-addr (header-length-in-a-units h))))))))
+
+(define (s48-extant? thing)
+  (or (not (stob? thing))
+      (not (in-oldspace? thing))
+      (stob? (stob-header thing))))
+
+;----------------
+; Weak pointers
+;
+; Weak pointers are copied into contiguous blocks so that they can be
+; scanned after the main GC has finished.  They have their own heap pointer
+; and heap limit.
+
+(define *weak-pointer-hp*)
+(define *weak-pointer-limit*)
+
+; header + one slot
+(define weak-pointer-size 2)
+
+; The number of weak pointers in each block.
+(define weak-pointer-alloc-count 128)
+
+; The size of a block of weak pointers.
+(define weak-pointer-alloc-quantum
+  (cells->a-units (* weak-pointer-alloc-count weak-pointer-size)))
+
+; Used both to detect weak pointers and for setting the headers when the
+; weak-pointer blocks are scanned.
+(define weak-pointer-header
+  (make-header (enum stob weak-pointer) (cells->bytes (- weak-pointer-size 1))))
+
+; A header used to stop the GC from scanning weak-pointer blocks.
+(define weak-alloc-area-header
+  (make-header (enum stob byte-vector)
+	       (cells->bytes (- (* weak-pointer-alloc-count weak-pointer-size)
+				1))))  ; don't count the header
+
+(define (copy-weak-pointer weak frontier)
+  (let ((frontier (if (or (null-address? *weak-pointer-hp*)
+			  (address>= *weak-pointer-hp* *weak-pointer-limit*))
+		      (allocate-more-weak-pointer-space frontier)
+		      frontier)))
+    (let ((new (address->stob-descriptor
+		(address+ *weak-pointer-hp* (cells->a-units stob-overhead)))))
+      (store! (address1+ *weak-pointer-hp*) (fetch (address-after-header weak)))
+      (set! *weak-pointer-hp* (address2+ *weak-pointer-hp*))
+      (stob-header-set! weak new) ;***Break heart
+      (values new frontier))))
+
+; The weak pointer blocks are linked in their third slot (= the header space
+; of the second weak pointer).  The header for the first weak pointer contains
+; a header for the block, and the value slots contain the (untraced) values.
+
+(define (allocate-more-weak-pointer-space frontier)
+  (let ((old *weak-pointer-hp*)
+	(new-frontier (address+ frontier weak-pointer-alloc-quantum)))
+    (set! *weak-pointer-hp* frontier)
+    (set! *weak-pointer-limit* new-frontier)
+    (store! *weak-pointer-hp* weak-alloc-area-header)
+    (store! (address2+ *weak-pointer-hp*) (address->integer old))
+    new-frontier))
+
+; If any weak pointers were found, then get the limits of the most recently
+; allocated block and scan it and the rest of the blocks.  Put a string header
+; on the unused portion of the block the most recent block.
+
+(define (clean-weak-pointers)
+  (if (not (null-address? *weak-pointer-hp*))
+      (let ((start (address- *weak-pointer-limit* weak-pointer-alloc-quantum))
+	    (end *weak-pointer-hp*))
+	(scan-weak-pointer-blocks start end)
+	(if (not (address>= end *weak-pointer-limit*))
+	    (let ((unused-portion (address-difference *weak-pointer-limit*
+						      (address1+ end))))
+	      (store! end (make-header (enum stob byte-vector)
+				       (cells->bytes
+					(a-units->cells unused-portion)))))))))
+
+(define (scan-weak-pointer-blocks start end)
+  (let loop ((start start) (end end))
+    (let ((next (integer->address (fetch (address2+ start)))))
+      (scan-weak-pointer-block start end)
+      (if (not (null-address? next))
+	  (loop (address- next weak-pointer-alloc-quantum) next)))))
+
+; Go from START to END putting headers on the weak pointers and seeing if
+; their contents were traced.
+
+(define (scan-weak-pointer-block start end)
+  (do ((scan start (address2+ scan)))
+      ((address>= scan end))
+    (store! scan weak-pointer-header)
+    (let ((value (fetch (address1+ scan))))
+      (if (and (in-oldspace? value)
+	       (stob? value))
+	  (store! (address1+ scan)
+		  (let ((h (stob-header value)))
+		    (if (stob? h) h false)))))))
+
+;----------------
+; Undumpable records
+;
+; Record types may be marked as `undumpable', in which case they are replaced in
+; images by the value of their first slot.
+
+(define (undumpable? x)
+  (and (gc-record? x)
+       (let ((type (record-ref x 0)))
+	 (and (gc-record? type)
+	      (= false (record-ref type 1))))))
+
+(define (gc-record? x)
+  (and (stob? x)
+       (let ((header (stob-header x)))
+	 (if (stob? header)
+	     (record? header)
+	     (record? x)))))
+
+(define (undumpable-alias record)
+  (record-ref record 1))
+
+; This is a bit weird.
+;
+; We want to cons a list of undumpable records that the user is trying to dump.
+; The list is used by the write-image instruction after the image is written out,
+; so it needs to be in what is currently oldspace.  We swap the spaces, cons
+; onto the list, and then swap back.
+;
+; We only return the first one-thousand undumpable objects because:
+;  A. It is unlikely anyone will want more.
+;  B. We don't want to get hung up in MEMQ? in pathological cases.
+;  C. Using an NlogN algorithm would be too much work for this.
+
+(define (note-undumpable! thing)
+  (if (and (<= *undumpable-count* 1000)
+	   (not (vm-memq? thing *undumpable-records*)))
+      (begin
+	(set! *undumpable-count* (+ 1 *undumpable-count*))
+	(swap-spaces)
+	(if (s48-available? vm-pair-size)
+	    (set! *undumpable-records*
+		  (vm-cons thing
+			   *undumpable-records*
+			   (s48-preallocate-space vm-pair-size))))
+	(swap-spaces))))
+
+(define (vm-memq? thing list)
+  (let loop ((list list))
+    (cond ((vm-eq? null list)
+	   #f)
+	  ((vm-eq? (vm-car list) thing)
+	   #t)
+	  (else
+	   (loop (vm-cdr list))))))
diff --git a/scheme/vm/generic-arith.scm b/scheme/vm/generic-arith.scm
new file mode 100644
index 0000000..9d3dce1
--- /dev/null
+++ b/scheme/vm/generic-arith.scm
@@ -0,0 +1,366 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Generic arithmetic.
+
+; The different kinds of numbers.
+
+(define-enumeration numbers
+  (fixnum
+   bignum
+   rational
+   float
+   complex
+   not-a-number))
+
+; Mapping numbers to their representation.
+
+(define stob-numbers
+  (make-vector stob-count (enum numbers not-a-number)))
+
+; For now all we have are bignums (and fixnums, of course).
+(vector-set! stob-numbers (enum stob bignum) (enum numbers bignum))
+
+(define (number->representation x)
+  (cond ((fixnum? x)
+	 (enum numbers fixnum))
+	((stob? x)
+	 (vector-ref stob-numbers (header-type (stob-header x))))
+	(else
+	 (enum numbers not-a-number))))
+
+;----------------
+; Tables for unary and binary operations.  All entries initially return DEFAULT.
+
+(define (make-unary-table default)
+  (make-vector numbers-count
+	       (lambda (x)
+		 default)))
+	
+; (unary-table-set! <table> <type> <value>)
+; (unary-table-set! <table> (<type> ...) <value>)
+
+(define-syntax unary-table-set!
+  (syntax-rules ()
+    ((unary-table-set! ?table (?kind ...) ?value)
+     (real-unary-table-set! ?table (list (enum numbers ?kind) ...) ?value))
+    ((unary-table-set! ?table ?kind ?value)
+     (real-unary-table-set! ?table (list (enum numbers ?kind)) ?value))))
+
+(define (real-unary-table-set! table kinds value)
+  (for-each (lambda (kind)
+	      (vector-set! table kind value))
+	    kinds))
+
+(define (unary-dispatch table x)
+  ((vector-ref table
+	       (number->representation x))
+     x))
+
+(define (make-binary-table default)
+  (make-vector (* numbers-count numbers-count)
+	       (lambda (x y)
+		 default)))
+
+; Same as for unary tables, except that we have two indexes or lists of indexes.
+
+(define-syntax binary-table-set!
+  (syntax-rules ()
+    ((binary-table-set! ?table (?kind0 ...) (?kind1 ...) ?value)
+     (real-binary-table-set! ?table
+			     (list (enum numbers ?kind0) ...)
+			     (list (enum numbers ?kind1) ...)
+			     ?value))
+    ((binary-table-set! ?table (?kind0 ...) ?kind1 ?value)
+     (real-binary-table-set! ?table
+			     (list (enum numbers ?kind0) ...)
+			     (list (enum numbers ?kind1))
+			     ?value))
+    ((binary-table-set! ?table ?kind0 (?kind1 ...) ?value)
+     (real-binary-table-set! ?table
+			     (list (enum numbers ?kind0))
+			     (list (enum numbers ?kind1) ...)
+			     ?value))
+    ((binary-table-set! ?table ?kind0 ?kind1 ?value)
+     (real-binary-table-set! ?table
+			     (list (enum numbers ?kind0))
+			     (list (enum numbers ?kind1))
+			     ?value))))
+
+(define (real-binary-table-set! table kinds0 kinds1 value)
+  (for-each (lambda (kind0)
+	      (for-each (lambda (kind1)
+			  (vector-set! table
+				       (+ (* kind0 numbers-count)
+					  kind1)
+				       value))
+			kinds1))
+	    kinds0))
+
+; Does this need to be changed to get a computed goto?
+
+(define (binary-dispatch table x y)
+  ((vector-ref table
+	       (+ (* (number->representation x)
+		     numbers-count)
+		  (number->representation y)))
+     x
+     y))
+
+(define (binary-lose x y)
+  unspecific-value)
+
+;----------------
+; The actual opcodes
+
+; Predicates
+
+(define-primitive number? (any->)
+  (lambda (x)
+    (not (= (number->representation x)
+	    (enum numbers not-a-number))))
+  return-boolean)
+
+(define-primitive integer? (any->)
+  (lambda (x)
+    (let ((type (number->representation x)))
+      (or (= type (enum numbers fixnum))
+	  (= type (enum numbers bignum)))))
+  return-boolean)
+
+(define-primitive rational? (any->)
+  (lambda (x)
+    (let ((type (number->representation x)))
+      (or (= type (enum numbers fixnum))
+	  (= type (enum numbers bignum))
+	  (= type (enum numbers rational)))))
+  return-boolean)
+
+(define-primitive real? (any->)
+  (lambda (x)
+    (let ((type (number->representation x)))
+      (not (or (= type (enum numbers complex))
+	       (= type (enum numbers not-a-number))))))
+  return-boolean)
+
+(define-primitive complex? (any->)
+  (lambda (x)
+    (not (= (number->representation x)
+	    (enum numbers not-a-number))))
+  return-boolean)
+
+(define-primitive exact? (any->)
+  (lambda (x)
+    (enum-case number (number->representation x)
+	       ((float)
+		(goto return-boolean #f))
+	       ((complex)
+		(goto return-boolean (not (float? (complex-real-part x)))))
+	       ((not-a-number)
+		(raise-exception wrong-type-argument 0 x))
+	       (else
+		(goto return-boolean #t)))))
+
+;----------------
+; Arithmetic
+
+(define-syntax define-binary-primitive
+  (syntax-rules ()
+    ((define-binary-primitive id table careful integer)
+     (define table (make-binary-table binary-lose))
+     (define-primitive id (any-> any->)
+       (lambda (x y)
+	 (if (and (fixnum? x)
+		  (fixnum? y))
+	     (goto careful
+		   x
+		   y
+		   return
+		   (lambda (x y)
+		     (goto return (integer x y))))
+	     (let ((r (binary-dispatch table x y)))
+	       (if (vm-eq? r unspecific-value)
+		   (raise-exception wrong-type-argument 0 x y)
+		   (goto return r))))))
+     (binary-table-set! table (fixnum bignum) (fixnum bignum) integer))))
+
+(define-binary-primitive + add-table add-carefully integer-add)
+(define-binary-primitive - subtract-table subtract-carefully integer-subtract)
+(define-binary-primitive * multiply-table multiply-carefully integer-multiply)
+(define-binary-primitive quotient quotient-table quotient-carefully integer-quotient)
+(define-binary-primitive remainder remainder-table remainder-carefully integer-remainder)
+(define-binary-primitive arithmetic-shift shift-table shift-carefully integer-shift)
+
+; Hm.  There is no integer-divide (obviously)
+
+(define-binary-primitive / divide-table divide-carefully integer-)
+
+
+
+
+
+
+
+
+
+
+
+
+****************************************************************
+
+How to structure all this?  It would be nice if the interpreter could be
+broken into several modules.  The registers and define-primitive would
+need to be separated out.
+
+;----------------
+; Tower predicates.
+; These need to be changed.
+
+(define-unary-opcode-extension integer?       &integer?  #f)
+(define-unary-opcode-extension rational?      &rational? #f)
+(define-unary-opcode-extension real?          &real?     #f)
+(define-unary-opcode-extension complex?       &complex?  #f)
+(define-unary-opcode-extension number?        &number?   #f)
+(define-unary-opcode-extension exact?         &exact?    #f)
+
+(let ((true (lambda (x) #t)))
+  (unary-table-set! &integer?  (fixnum bignum)                        true)
+  (unary-table-set! &rational? (fixnum bignum rational)               true)
+  (unary-table-set! &real?     (fixnum bignum rational float)         true)
+  (unary-table-set! &complex?  (fixnum bignum rational float complex) true)
+  (unary-table-set! &number?   (fixnum bignum rational float complex) true)
+  (unary-table-set! &exact?    (fixnum bignum rational)               true))
+
+; The two parts of a complex number must have the same exactness.
+
+(unary-table-set! &exact? (complex)
+		  (lambda (z)
+		    (real-part z)))
+
+;----------------
+; Imaginary operations.
+
+(define-unary-opcode-extension real-part      &real-part (lambda (x) x))
+(define-unary-opcode-extension imag-part      &imag-part (lambda (x) 0))
+
+(unary-table-set! &real-part (complex not-a-number)
+		  (lambda (x) unimplemented))
+
+(unary-table-set! &imag-part (complex not-a-number)
+		  (lambda (x) unimplemented))
+
+;----------------
+; Fractions
+
+(define-unary-opcode-extension floor          &floor)
+(define-unary-opcode-extension numerator      &numerator)
+(define-unary-opcode-extension denominator    &denominator)
+
+(define (identity x) x)
+
+(unary-table-set! &floor       (fixnum bignum) identity)
+(unary-table-set! &numerator   (fixnum bignum) identity)
+(unary-table-set! &denominator (fixnum bignum) (lambda (x) 1))
+
+;----------------
+; Square root.
+
+(define-unary-opcode-extension sqrt &sqrt)
+
+; The bignum code could whack this.
+; The VM doesn't do sqrt for positive fixnums.  I wonder why?
+
+; For negative N, we lose if MAKE-RECTANGULAR loses.
+
+(unary-table-set! &sqrt (fixnum bignum)
+  (lambda (n)
+    (if (>= n 0)
+	(non-negative-integer-sqrt n)	;Dubious (JAR)
+	(let ((s (non-negative-integer-sqrt (- n))))
+	  (if (eq? s unimplemented)
+	      s
+	      (binary-dispatch &make-rectangular
+			       0
+			       s))))))
+
+; Courtesy of Mr. Newton.
+
+(define (non-negative-integer-sqrt n)
+  (if (<= n 1)    ; for both 0 and 1
+      n
+      (let loop ((m (quotient n 2)))
+	(let ((m1 (quotient n m)))
+	  (cond ((< m1 m)
+		 (loop (quotient (+ m m1) 2)))
+		((= n (* m m))
+		 m)
+		(else
+		 unimplemented))))))
+
+;----------------
+; Make sure this has very low priority, so that it's only tried as a
+; last resort.
+;
+; In fact, I'll comment it out completely. -RK
+
+;(define-method &/ (m n)
+;  (if (and (integer? m) (integer? n))
+;      (if (= 0 (remainder m n))
+;          (quotient m n)
+;          (let ((z (abs (quotient n 2))))
+;            (set-exactness (quotient (if (< m 0)
+;                                         (- m z)
+;                                         (+ m z))
+;                                     n)
+;                           #f)))
+;      (next-method)))
+
+;----------------
+; The rest have no useful defaults.
+
+(define-unary-opcode-extension exact->inexact &exact->inexact)
+(define-unary-opcode-extension inexact->exact &inexact->exact)
+
+(define-binary-opcode-extension +              &+)
+(define-binary-opcode-extension -              &-)
+(define-binary-opcode-extension *              &*)
+(define-binary-opcode-extension /              &/)
+(define-binary-opcode-extension =              &=)
+(define-binary-opcode-extension <              &<)
+(define-binary-opcode-extension quotient       &quotient)
+(define-binary-opcode-extension remainder      &remainder)
+  
+(define-binary-opcode-extension make-rectangular &make-rectangular)
+
+(define-unary-opcode-extension exp  &exp)
+(define-unary-opcode-extension log  &log)
+(define-unary-opcode-extension sin  &sin)
+(define-unary-opcode-extension cos  &cos)
+(define-unary-opcode-extension tan  &tan)
+(define-unary-opcode-extension asin &asin)
+(define-unary-opcode-extension acos &acos)
+(define-unary-opcode-extension atan &atan)
+
+; >, <=, and >= are all extended using the table for <.
+
+(extend-opcode! (enum op >)
+		(lambda (lose)
+		  (lambda (reason arg0 arg1)
+		    (let ((res (binary-dispatch &< arg1 arg0)))
+		      (if (eq? res unimplemented)
+			  (lose reason arg0 arg1)
+			  res)))))
+(extend-opcode! (enum op <=)
+		(lambda (lose)
+		  (lambda (reason arg0 arg1)
+		    (let ((res (binary-dispatch &< arg1 arg0)))
+		      (if (eq? res unimplemented)
+			  (lose reason arg0 arg1)
+			  (not res))))))
+(extend-opcode! (enum op >=)
+		(lambda (lose)
+		  (lambda (reason arg0 arg1)
+		    (let ((res (binary-dispatch &< arg0 arg1)))
+		      (if (eq? res unimplemented)
+			  (lose reason arg0 arg1)
+			  (not res))))))
+
diff --git a/scheme/vm/heap.scm b/scheme/vm/heap.scm
new file mode 100644
index 0000000..8ae2c4b
--- /dev/null
+++ b/scheme/vm/heap.scm
@@ -0,0 +1,277 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Allocation
+;  s48-*hp* is the heap pointer and s48-*limit* is the limit beyond which no
+;  storage should be allocated.  Both of these are addresses (not
+;  descriptors).
+
+(define s48-*hp*)
+(define s48-*limit*)
+
+(define *oldspace-hp*)
+(define *oldspace-limit*)
+
+; These are all in address units
+(define *newspace-begin*)
+(define *newspace-end*)
+(define *oldspace-begin*)
+(define *oldspace-end*)
+
+; For the GC (which is in another module)
+
+(define (heap-pointer)
+  s48-*hp*)
+
+(define (set-heap-pointer! new-hp)
+  (set! s48-*hp* new-hp))
+
+(define (heap-start)
+  *newspace-begin*)
+
+(define (heap-limit)
+  *newspace-end*)
+
+;----------------
+
+(define (s48-initialize-heap start size)
+  (let ((semisize (cells->a-units (quotient size 2))))
+    (set! *newspace-begin* start)
+    (set! *newspace-end* (address+ *newspace-begin* semisize))
+    (set! s48-*hp* *newspace-begin*)
+    (set! s48-*limit* *newspace-end*)
+    (set! *oldspace-begin* *newspace-end*)
+    (set! *oldspace-end* (address+ *oldspace-begin* semisize))
+    (set! *oldspace-hp* *oldspace-begin*)
+    (set! *oldspace-limit* *oldspace-end*)))
+
+; To write images we need to be able to undo the swapping.
+
+(define-syntax swap!
+  (syntax-rules ()
+    ((swap! a b)
+     (let ((temp a))
+       (set! a b)
+       (set! b temp)))))
+
+(define (swap-spaces)
+  (swap! s48-*limit*          *oldspace-limit*)
+  (swap! s48-*hp*             *oldspace-hp*)
+  (swap! *newspace-begin* *oldspace-begin*)
+  (swap! *newspace-end*   *oldspace-end*))
+
+;----------------
+
+(define (s48-available? cells)
+  (address< (address+ s48-*hp* (cells->a-units cells)) s48-*limit*))
+
+(define (s48-available)
+  (a-units->cells (address-difference s48-*limit* s48-*hp*)))
+
+(define (s48-heap-size)
+  (address-difference *newspace-end* *newspace-begin*))
+
+(define (store-next! descriptor)
+  (store! s48-*hp* descriptor)
+  (set! s48-*hp* (address1+ s48-*hp*)))
+
+; Pre-Allocation
+;
+; Preallocation and keys are used to ensure that for every call to MAKE-STOB
+; there is a corresponding call to ENSURE-SPACE to see if there is sufficient
+; heap space.  ENSURE-SPACE returns a key and MAKE-STOB checks that the
+; key it is passed is the most recently allocated key and that the space
+; needed is no greater than the argument to ENSURE-SPACE.
+; 
+; Another solution would be to make ENSURE-SPACE and MAKE-STOB a single
+; procedure.  The difficulty is that ENSURE-SPACE may trigger a garbage
+; collection, which in turn requires that all live data be reachable
+; from the VM's registers.  The VM solves this by only calling ENSURE-SPACE
+; at the beginning of an instruction, before any values have been removed
+; from the stack or any of the registers.  Once the key has been obtained
+; the instruction is free to make any number of calls to MAKE-STOB, as long
+; as the total heap space required is no more than what was checked for.
+; 
+; There is a flag, CHECK-PREALLOCATION?, that determines whether MAKE-STOB
+; actually checks the keys.  In the VM as seen by the Pre-Scheme compiler
+; this flag is defined to be #f and never set, so all of the key code is
+; constant-folded into oblivion.
+; 
+; The main virtue of the keys is not that they can be checked but
+; that they exist at all.  MAKE-STOB requires a key argument, and
+; if there is none available you know that you forgot an ENSURE-SPACE.
+; Occasionally I run the VM in Scheme with checking enabled, just
+; to see if it all still works.
+
+(define check-preallocation? #f)
+
+(define *heap-key* 0)
+(define *okayed-space* 0)
+
+(define (s48-preallocate-space cells)
+  (cond (check-preallocation?
+	 (assert (s48-available? cells))
+	 (set! *heap-key* (+ *heap-key* 1))
+	 (set! *okayed-space* cells)
+	 *heap-key*)
+	(else
+	 0)))
+
+(define (s48-allocate-space type len key)	;len is in bytes
+  (= type 0)      ; declaration for type-checker
+  (if check-preallocation?
+      (let ((cells (+ (bytes->cells len) 1)))
+	(assert (s48-available? cells))
+	(if (not (and (= key *heap-key*)
+		      (>= *okayed-space* cells)))
+	    (error "invalid heap key" key cells))
+	(set! *okayed-space* (- *okayed-space* cells))))
+  (let ((new s48-*hp*))
+    (set! s48-*hp* (address+ s48-*hp* (bytes->a-units len)))
+    new))
+
+(define (s48-write-barrier stob address value)
+  (address+ address (+ stob value))  ; for the type checker
+  (unspecific))
+
+;----------------
+; Keeping track of all the areas.
+
+(define *pure-areas*)
+(define *impure-areas*)
+(define *pure-sizes*)
+(define *impure-sizes*)
+(define *pure-area-count* 0)
+(define *impure-area-count* 0)
+
+(define (have-static-areas?)
+  (or (< 0 *impure-area-count*)
+      (< 0 *pure-area-count*)))
+
+(define (s48-register-static-areas pure-count pure-areas pure-sizes
+				   impure-count impure-areas impure-sizes)
+  (set! *pure-area-count* pure-count)
+  (set! *pure-areas* pure-areas)
+  (set! *pure-sizes* pure-sizes)
+  (set! *impure-area-count* impure-count)
+  (set! *impure-areas* impure-areas)
+  (set! *impure-sizes* impure-sizes))
+
+(define (walk-areas proc areas sizes count)
+  (let loop ((i 0))
+    (cond ((>= i count)
+	   #t)
+	  ((proc (vector-ref areas i)
+		 (address+ (vector-ref areas i)
+			   (vector-ref sizes i)))
+	   (loop (+ i 1)))
+	  (else
+	   #f))))
+
+(define (walk-pure-areas proc)
+  (if (< 0 *pure-area-count*)
+      (walk-areas proc *pure-areas* *pure-sizes* *pure-area-count*)))
+
+(define (walk-impure-areas proc)
+  (if (< 0 *impure-area-count*)
+      (walk-areas proc *impure-areas* *impure-sizes* *impure-area-count*)))
+
+;----------------------------------------------------------------
+; Finding things in the heap.
+
+(define *finding-type* (enum stob symbol))    ; work around lack of closures
+
+; Call PREDICATE on all objects of type *FINDING-TYPE* found between START and END.
+; The objects for which PREDICATE returns #T are pushed onto the heap using STORE-NEXT!.
+; Returns #T for success and #F for failure.
+
+(define (collect-type-in-area predicate)
+  (lambda (start end)
+    (let ((type *finding-type*))
+      (let loop ((addr start))
+	(if (address>= addr end)
+	    #t
+	    (let* ((d (fetch addr))
+		   (next (address+ addr
+				   (+ (cells->a-units stob-overhead)
+				      (header-length-in-a-units d)))))
+	      (cond ((not (header? d))
+		     (write-string "heap is in an inconsistent state."
+				   (current-error-port))
+		     #f)
+		    ((not (= type (header-type d)))
+		     (loop next))
+		    (else
+		     (let ((obj (address->stob-descriptor (address1+ addr))))
+		       (cond ((not (predicate obj))
+			      (loop next))
+			     ((s48-available? (cells->a-units 1))
+			      (store-next! obj)
+			      (loop next))
+			     (else
+			      #f)))))))))))
+
+; Returns a procedure that will walk the heap calling PREDICATE on every
+; object of a particular type.  Returns a vector containing all objects
+; for which PREDICATE returns #t.  If the heap is screwed up or there isn't
+; room for the vector we return FALSE.
+
+(define (generic-find-all predicate)
+  (let ((proc (collect-type-in-area predicate)))
+    (lambda (type)
+      (set! *finding-type* type)                     ; we don't have closures
+      (let ((start-hp s48-*hp*))
+	(store-next! 0)                              ; reserve space for header
+	(cond ((and (proc *newspace-begin* start-hp)
+		    (walk-impure-areas proc)
+		    (walk-pure-areas proc))
+	       (let ((size (address-difference s48-*hp* (address1+ start-hp))))
+		 (store! start-hp (make-header (enum stob vector) size) )
+		 (address->stob-descriptor (address1+ start-hp))))
+	      (else
+	       (set! s48-*hp* start-hp) ; out of space, so undo and give up
+	       false))))))
+
+; Find everything with a given type.
+
+(define s48-find-all
+  (generic-find-all (lambda (thing) #t)))
+
+; Find all records of a given record type (as determined by the first slot
+; in each record).
+
+(define s48-find-all-records
+  (let* ((the-record-type false)
+	 (finder (generic-find-all
+		  (lambda (record)
+		    (vm-eq? (record-type record)
+			    the-record-type)))))
+    (lambda (record-type)
+      (set! the-record-type record-type)
+      (finder (enum stob record)))))
+
+(define find-resumer-records
+  (let ((finder (generic-find-all
+		  (lambda (record)
+		    (let ((type (record-type record)))
+		      (and (record? type)
+			   (stob? (record-type-resumer type))))))))
+    (lambda ()
+      (finder (enum stob record)))))
+
+; Functions for accessing records.  Getting these from STRUCT would introduce
+; a circular module dependency.
+
+(define (record? x)
+  (and (stob? x)
+       (= (header-type (stob-header x))
+	  (enum stob record))))
+    
+(define (record-type record)
+  (record-ref record -1))
+
+(define (record-type-resumer record-type)
+  (record-ref record-type 0))
+
+(define (record-ref record offset)
+  (fetch (address+ (address-after-header record)
+		   (cells->a-units (+ offset 1)))))
diff --git a/scheme/vm/image.scm b/scheme/vm/image.scm
new file mode 100644
index 0000000..bc374e1
--- /dev/null
+++ b/scheme/vm/image.scm
@@ -0,0 +1,328 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Write-image and read-image
+
+(define (s48-image-writing-okay?)
+  (not (have-static-areas?)))
+
+(define *status* (enum errors no-errors))
+
+(define-syntax write-check
+  (syntax-rules ()
+    ((write-check exp)
+     (if (eq? *status* (enum errors no-errors))
+	 (set! *status* exp)))))
+
+(define (write-heap-integer n port)
+  (write-check (write-integer n port))
+  (write-check (write-char #\newline port)))
+
+(define (s48-write-image resume-proc port)
+  (begin-writing-image)
+  (let ((resume-proc (s48-trace-value resume-proc))
+	(exported-bindings (s48-trace-value (s48-exported-bindings))))
+    (s48-do-gc)
+    (s48-mark-traced-channels-closed!)
+    (let ((symbols (s48-copy-symbol-table))
+	  (imported-bindings (s48-cleaned-imported-bindings))
+	  (resumer-records (find-resumer-records)))
+      (if (vm-eq? false resumer-records)
+	  (begin
+	    (abort-collection)
+	    (enum errors out-of-memory))
+	  (let ((status (really-write-image port resume-proc
+					    symbols
+					    imported-bindings
+					    exported-bindings
+					    resumer-records)))
+	    (abort-collection)
+	    status)))))
+
+(define (really-write-image port restart-proc
+			    symbols imported-bindings exported-bindings
+			    resumer-records)
+  (set! *status* (enum errors no-errors))
+  (write-check (write-char #\newline port))
+  (write-check (write-page port))
+  (write-check (write-char #\newline port))
+  (write-check (write-string architecture-version port))
+  (write-check (write-char #\newline port))
+  (write-heap-integer bytes-per-cell port)
+  (write-heap-integer (a-units->cells (address->integer (heap-start))) port)
+  (write-heap-integer (a-units->cells (address->integer (heap-pointer))) port)
+  (write-heap-integer symbols port)
+  (write-heap-integer imported-bindings port)
+  (write-heap-integer exported-bindings port)
+  (write-heap-integer resumer-records port)
+  (write-heap-integer restart-proc port)
+  (write-check (write-page port))
+  (store! (heap-pointer) 1)  ; used to detect endianess of image
+  (write-check (write-block port
+			    (heap-pointer)
+			    (address-difference (address1+ (heap-pointer)) (heap-pointer))))
+  (write-check (write-block port
+			    (heap-start)
+			    (address-difference (heap-pointer) (heap-start))))
+  *status*)
+
+; Make sure the image file is okay and return the size of the heap it
+; contains.
+
+(define *eof?* #f)
+
+(define-syntax read-check
+  (syntax-rules ()
+    ((read-check exp)
+     (read-check exp -1))
+    ((read-check exp losing-value)
+     (let ((lose losing-value))
+       (if *eof?*
+	   lose
+	   (receive (thing eof? status)
+	       exp
+	     (cond (eof?
+		    (set! *eof?* #t)
+		    lose)
+		   ((eq? *status* (enum errors no-errors))
+		    thing)
+		   (else
+		    (set! *eof?* #t)
+		    (set! *status* status)
+		    lose))))))))
+
+; Read in the ASCII portion of the image and make sure that it is compatible
+; with this version of the VM.
+
+(define (s48-check-image-header filename)
+  (receive (port status)
+      (open-input-file filename)
+    (cond ((error? status)
+	   (error-message  "Can't open heap image file")
+	   (error-message (error-string status))
+	   -1)
+	  (else
+	   (set! *status* (enum errors no-errors))
+	   (set! *eof?* #f)
+	   (read-check (read-page port))
+	   (read-check (read-newline port)) ; version starts on next line
+	   (let* ((same-version? (read-check (check-image-version port) #f))
+		  (old-bytes-per-cell (read-check (read-integer port))))
+	     (set! *old-begin*
+		   (integer->address
+		     (cells->a-units (read-check (read-integer port)))))
+	     (set! *old-hp*
+		   (integer->address
+		     (cells->a-units (read-check (read-integer port)))))
+	     (set! *symbols*           (read-check (read-integer port)))
+	     (set! *imported-bindings* (read-check (read-integer port)))
+	     (set! *exported-bindings* (read-check (read-integer port)))
+	     (set! *resumer-records*   (read-check (read-integer port)))
+	     (set! *startup-procedure* (read-check (read-integer port)))
+	     (set! *image-port* port)
+	     (read-check (read-page port)) ; read to beginning of heap
+	     (cond ((error? *status*)
+		    (read-lost "Error reading from image file" port))
+		   (*eof?*   ; has to come after *status* check
+		    (set! *status* (enum errors parse-error))
+		    (read-lost "Premature EOF when reading image file" port))
+		   ((not same-version?)
+		    (read-lost "Format of image is incompatible with this version of system" port))
+		   ((not (= old-bytes-per-cell bytes-per-cell))
+		    (read-lost "Incompatible bytes-per-cell in image" port))
+		   (else
+		    (address-difference *old-hp* *old-begin*))))))))
+
+(define (read-page port)
+  (read-this-character page-character port))
+
+(define (read-newline port)
+  (read-this-character #\newline port))
+
+(define (read-this-character char port)
+  (let loop ()
+    (receive (ch eof? status)
+	(read-char port)
+      (cond ((or eof? (error? status))
+	     (values -1 eof? status))
+	    ((char=? char ch)
+	     (values -1 #f status))
+	    (else
+	     (loop))))))
+
+(define (check-image-version port)
+  (let ((len (string-length architecture-version)))
+    (let loop ((i 0))
+      (receive (ch eof? status)
+	  (read-char port)
+	(cond ((or eof? (error? status))
+	       (values #f eof? status))
+	      ((= i len)
+	       (values (char=? #\newline ch) #f status))
+	      ((char=? ch (string-ref architecture-version i))
+	       (loop (+ i 1)))
+	      (else
+	       (values #f #f status)))))))
+
+(define *image-port*)
+(define *old-begin*)
+(define *old-hp*)
+
+;----------------
+; Values provided by the image file.
+
+(define *startup-procedure*)
+(define *symbols*)
+(define *imported-bindings*)
+(define *exported-bindings*)
+(define *resumer-records*)
+
+(define *initializing?* #t)
+
+; Save initial values across any GC's.
+
+(define (s48-initializing-gc-root)
+  (if *initializing?*
+      (begin
+	(set! *startup-procedure* (s48-trace-value *startup-procedure*))
+	(set! *symbols*           (s48-trace-value *symbols*))
+	(set! *imported-bindings* (s48-trace-value *imported-bindings*))
+	(set! *exported-bindings* (s48-trace-value *exported-bindings*))
+	(set! *resumer-records*   (s48-trace-value *resumer-records*)))))
+  
+; For the outside world.
+
+(define (s48-startup-procedure)         *startup-procedure*)
+(define (s48-initial-symbols)           *symbols*)
+(define (s48-initial-imported-bindings) *imported-bindings*)
+(define (s48-initial-exported-bindings) *exported-bindings*)
+(define (s48-resumer-records)           *resumer-records*)
+
+(define (s48-initialization-complete!)
+  (set! *initializing?* #f))
+
+; For resuming static images.
+
+(define (s48-set-image-values! startup-proc symbols imports exports records)
+  (set! *startup-procedure* startup-proc)
+  (set! *symbols*           symbols)
+  (set! *imported-bindings* imports)
+  (set! *exported-bindings* exports)
+  (set! *resumer-records*   records))
+
+;----------------
+
+(define (s48-read-image)
+  (let ((port *image-port*))
+    (receive (okay? string)
+	(image-read-block port (cells->a-units 1))
+      (cond ((not okay?)
+	     (read-lost string port))
+	    ((= (fetch (heap-pointer)) 1)
+	     (really-read-image port #f))
+	    (else
+	     (reverse-descriptor-byte-order! (heap-pointer))
+	     (if (= (fetch (heap-pointer)) 1)
+		 (really-read-image port #t)
+		 (read-lost "Unable to correct byte order" port)))))))
+
+(define (really-read-image port reverse?)
+  (let* ((delta (address-difference (heap-pointer) *old-begin*))
+	 (new-hp (address+ *old-hp* delta))
+	 (new-limit (heap-limit))
+	 (start (heap-pointer)))
+    (if (address>= new-hp new-limit)
+	(read-lost "Heap not big enough to restore this image" port)
+	(receive (okay? string)
+	    (image-read-block port (address-difference *old-hp* *old-begin*))
+	  (receive (ch eof? status)
+	      (read-char port)
+	    (cond ((not okay?)
+		   (read-lost string port))
+		  ((error? status)
+		   (read-lost "Error reading from image file" port))
+		  ((not eof?)
+		   (read-lost "Image file has extraneous data after image" port))
+		  ((error? (close-input-port port))
+		   (read-lost "Error closing image file" port))
+		  (else
+		   (if reverse?
+		       (reverse-byte-order! start new-hp))
+		   (if (not (= delta 0))
+		       (relocate-image delta start new-hp))
+		   (set-heap-pointer! new-hp)
+		   (set! *startup-procedure* (adjust *startup-procedure* delta))
+		   (set! *symbols*           (adjust *symbols* delta))
+		   (set! *imported-bindings* (adjust *imported-bindings* delta))
+		   (set! *exported-bindings* (adjust *exported-bindings* delta))
+		   (set! *resumer-records*   (adjust *resumer-records* delta))
+		   0)))))))
+
+(define (image-read-block port need)
+  (receive (got eof? status)
+      (read-block port (heap-pointer) need)
+    (cond ((error? status)
+	   (set! *status* status)
+	   (values #f "Error reading from image file"))
+	  (eof?
+	   (values #f "Premature EOF when reading image file"))
+	  ((< got need)
+	   (values #f "Read returned too few bytes"))
+	  (else
+	   (values #t "")))))
+
+(define (read-lost message port)
+  (error-message message)
+  (if (error? *status*)
+      (error-message (error-string *status*)))
+  (if (error? (close-input-port port))
+      (error-message "Error closing image file"))
+  -1)
+
+; ABCD => DCBA
+
+; memory intensive, but independent of Scheme's integer size
+
+(define (reverse-descriptor-byte-order! addr)
+  (let ((x (fetch-byte addr)))
+    (store-byte! addr (fetch-byte (address+ addr 3)))
+    (store-byte! (address+ addr 3) x))
+  (let ((x (fetch-byte (address+ addr 1))))
+    (store-byte! (address+ addr 1) (fetch-byte (address+ addr 2)))
+    (store-byte! (address+ addr 2) x)))
+
+(define (reverse-byte-order! start end)
+  (error-message "Correcting byte order of resumed image.")
+  (let loop ((ptr start))
+    (if (address< ptr end)
+	(begin
+	  (reverse-descriptor-byte-order! ptr)
+	  (loop (let ((value (fetch ptr))
+		      (next (address1+ ptr)))
+		  (if (b-vector-header? value)
+		      (address+ next (header-length-in-a-units value))
+		      next)))))))
+
+(define (adjust descriptor delta)
+  (if (stob? descriptor)
+      (address->stob-descriptor
+        (address+ (address-after-header descriptor) delta))
+      descriptor))
+
+(define (relocate-image delta start end)
+  (let loop ((ptr start))
+    (if (address< ptr end)
+	(let ((d (adjust (fetch ptr) delta)))
+	  (store! ptr d)
+	  (loop (if (b-vector-header? d)
+		    (address+ (address1+ ptr) (header-length-in-a-units d))
+		    (address1+ ptr)))))))
+
+; The page character is used to mark the ends of the user and prelude sections
+; of image files.
+
+(define page-character (ascii->char 12))
+
+(define (write-page port)
+  (write-char page-character port))
+
diff --git a/scheme/vm/integer-op.scm b/scheme/vm/integer-op.scm
new file mode 100644
index 0000000..5a68829
--- /dev/null
+++ b/scheme/vm/integer-op.scm
@@ -0,0 +1,193 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Integer-only primitive operations
+
+; These predicates are used to characterize the numeric representations that
+; are implemented in the VM.
+
+(define (unary-lose x)
+  (raise-exception wrong-type-argument 0 x))
+
+(define (binary-lose x y)
+  (raise-exception wrong-type-argument 0 x y))
+
+; They're all numbers, even if we can't handle them.
+
+(define-primitive number? (any->)
+  (lambda (x)
+    (or (fixnum? x)
+	(bignum? x)
+	(ratnum? x)
+	(double? x)
+	(extended-number? x)))
+  return-boolean)
+  
+(define (vm-integer? n)
+  (cond ((or (fixnum? n)
+	     (bignum? n))
+	 (goto return-boolean #t))
+	((extended-number? n)
+	 (unary-lose n))
+	(else
+	 (goto return-boolean #f))))
+
+; These assume that ratnums and doubles aren't being used.
+
+(define-primitive integer?  (any->) vm-integer?)
+(define-primitive rational? (any->) vm-integer?)
+(define-primitive real?     (any->) vm-integer?)
+(define-primitive complex?  (any->) vm-integer?)
+
+;----------------
+; A macro for defining primitives that only operate on fixnums.
+
+(define-syntax define-integer-only
+  (syntax-rules ()
+    ((define-integer-only (opcode arg) value)
+     (define-primitive opcode (vm-integer->)
+       (lambda (arg)
+	 (goto return value))))
+    ((define-integer-only (opcode arg0 arg1) value)
+     (define-primitive opcode (vm-integer-> vm-integer->)
+       (lambda (arg0 arg1)
+	 (goto return value))))))
+
+; These primitives have a simple answer in the case of fixnums; for all others
+; they punt to the run-time system.
+
+(define-integer-only (exact?      n) true)
+(define-integer-only (real-part   n) n)
+(define-integer-only (imag-part   n) (enter-fixnum 0))
+(define-integer-only (floor       n) n)
+(define-integer-only (numerator   n) n)
+(define-integer-only (denominator n) (enter-fixnum 1))
+
+(define-primitive angle (vm-integer->)
+  (lambda (n)
+    (if (if (fixnum? n)
+	    (fx>= n (enter-fixnum 0))
+	    (bignum-nonnegative? n))
+	(goto return (enter-fixnum 0))
+	(unary-lose n))))
+
+(define-primitive magnitude (vm-integer->) integer-abs)
+
+; These all just raise an exception and let the run-time system do the work.
+
+(define-syntax define-punter
+  (syntax-rules ()
+    ((define-punter opcode)
+     (define-primitive opcode (any->) unary-lose))))
+
+(define-punter exact->inexact)
+(define-punter inexact->exact)
+(define-punter exp)
+(define-punter log)
+(define-punter sin)
+(define-punter cos)
+(define-punter tan)
+(define-punter asin)
+(define-punter acos)
+(define-punter sqrt)
+
+(define-syntax define-punter2
+  (syntax-rules ()
+    ((define-punter2 opcode)
+     (define-primitive opcode (any-> any->) binary-lose))))
+
+(define-punter2 atan)
+(define-punter2 make-polar)
+(define-punter2 make-rectangular)
+
+(define-syntax define-binop
+  (syntax-rules ()
+    ((define-binop opcode careful-op integer-op)
+     (define-primitive opcode (any-> any->)
+       (lambda (x y)
+	 (cond ((and (fixnum? x)
+		     (fixnum? y))
+		(goto careful-op
+		      x
+		      y
+		      return
+		      (lambda (x y)
+			(goto return (integer-op x y)))))
+	       ((and (vm-integer? x)
+		     (vm-integer? y))
+		(goto return (integer-op x y)))
+	       (else
+		(binary-lose x y))))))))
+
+(define-binop + add-carefully integer-add)
+(define-binop - subtract-carefully integer-subtract)
+(define-binop * multiply-carefully integer-multiply)
+(define-binop / divide-carefully integer-divide)
+(define-binop quotient         quotient-carefully integer-quotient)
+(define-binop remainder        remainder-carefully integer-remainder)
+;(define-binop arithmetic-shift shift-carefully)
+
+(define-syntax define-comparison
+  (syntax-rules ()
+    ((define-comparison opcode fixnum-op integer-op)
+     (define-primitive opcode (any-> any->)
+       (lambda (x y)
+	 (cond ((and (fixnum? x)
+		     (fixnum? y))
+		(goto careful-op
+		      x
+		      y
+		      return
+		      (lambda (x y)
+			(goto return (integer-op x y)))))
+	       ((and (vm-integer? x)
+		     (vm-integer? y))
+		(goto return (integer-op x y)))
+	       (else
+		(binary-lose x y))))))))
+
+(define-primitive = (any-> any->)
+  (lambda (x y)
+    (cond ((fixnum? x)
+	   (if (fixnum? y)
+	       (goto return-boolean (fixnum= x y))
+	       (if (bignum? y)
+		   (goto return-boolean #f)
+		   (binary-lose x y))))
+	  ((fixnum? y)
+	   (if (bignum? x)
+	       (goto return-boolean #f)
+	       (binary-lose x y)))
+	  ((and (bignum? x)
+		(bignum? y))
+	   (goto return-boolean (bignum= x y)))
+	  (else
+	   (binary-lose x y)))))
+
+(define-primitive < (any-> any->)
+  (lambda (x y)
+    (cond ((fixnum? x)
+	   (if (fixnum? y)
+	       (goto return-boolean (fixnum< x y))
+	       (if (bignum? y)
+		   (goto return-boolean (bignum-positive? y))
+		   (binary-lose x y))))
+	  ((fixnum? y)
+	   (if (bignum? x)
+	       (goto return-boolean (bignum-negative? x))
+	       (binary-lose x y)))
+	  ((and (bignum? x)
+		(bignum? y))
+	   (goto return-boolean (bignum< x y)))
+	  (else
+	   (binary-lose x y)))))
+
+(define-integer-only (<  x y) (enter-boolean (fixnum<  x y)))
+(define-integer-only (>  x y) (enter-boolean (fixnum>  x y)))
+(define-integer-only (<= x y) (enter-boolean (fixnum<= x y)))
+(define-integer-only (>= x y) (enter-boolean (fixnum>= x y)))
+
+(define-integer-only (bitwise-not x)   (fixnum-bitwise-not x))
+(define-integer-only (bitwise-and x y) (fixnum-bitwise-and x y))
+(define-integer-only (bitwise-ior x y) (fixnum-bitwise-ior x y))
+(define-integer-only (bitwise-xor x y) (fixnum-bitwise-xor x y))
diff --git a/scheme/vm/integer.scm b/scheme/vm/integer.scm
new file mode 100644
index 0000000..49d0d4d
--- /dev/null
+++ b/scheme/vm/integer.scm
@@ -0,0 +1,63 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Operations on integers.
+
+; This expects its arguments to be integers.
+
+(define (integer-op fixnum-op bignum-op)
+  (if (and (fixnum? x)
+	   (fixnum? y))
+      (fixnum-op x y (lambda (r) r) bignum-op)
+      (bignum-op x y)))
+  
+(define integer-add       (integer-op add-carefully       bignum-add))
+(define integer-subtract  (integer-op subtract-carefully  bignum-subtract))
+(define integer-multiply  (integer-op multiply-carefully  bignum-multiply))
+(define integer-quotient  (integer-op quotient-carefully  bignum-quotient))
+(define integer-remainder (integer-op remainder-carefully bignum-remainder))
+
+(define (integer-abs x)
+  (if (fixnum? x)
+      (abs-carefully x (lambda (r) r) bignum-abs)
+      (bignum-abs x)))
+
+; What about shifts and bitwise operations?
+
+; Fixnums and bignums are disjoint.
+
+(define (integer= x y)
+  (cond ((and (fixnum? x)
+	      (fixnum? y))
+	 (fixnum= x y))
+	((and (bignum? x)
+	      (bignum? y))
+	 (bignum= x y))
+	(else
+	 #f)))
+
+; Positive bignums are greater than all fixnums, negative bignums are less
+; than all fixnums.
+
+(define (integer< x y)
+  (cond ((fixnum? x)
+	 (if (fixnum? y)
+	     (fixnum< x y)
+	     (bignum-positive? y)))
+	((fixnum? y)
+	 (not (bignum-positive? y)))
+	(else
+	 (bignum< x y))))
+
+(define (integer<= x y)
+  (not (integer< y x)))
+
+(define (integer> x y)
+  (integer< y x))
+
+(define (integer>= x y)
+  (not (integer< x y)))
+
+
+	 
+		
diff --git a/scheme/vm/interfaces.scm b/scheme/vm/interfaces.scm
new file mode 100644
index 0000000..c4bdfa8
--- /dev/null
+++ b/scheme/vm/interfaces.scm
@@ -0,0 +1,506 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+(define-interface vm-utilities-interface
+  (export adjoin-bits low-bits high-bits unsigned-high-bits
+	  assert
+	  vector+length-fill!
+	  natural-for-each
+
+	  error?
+	  write-error-string write-error-integer write-error-newline
+	  error-message
+	  ))
+
+(define-interface vm-architecture-interface
+  (export architecture-version
+          (enum :syntax) ;so you don't have to remember to open enumerated
+	  bits-used-per-byte byte-limit
+	  (interrupt :syntax)
+	  interrupt-count
+	  (memory-status-option :syntax)
+	  (op :syntax)
+	  op-count
+	  opcode-arg-specs
+	  (exception :syntax)
+	  (stob :syntax)
+	  stob-count
+	  least-b-vector-type
+	  stob-data
+	  (time-option :syntax)
+	  (channel-status-option :syntax)
+	  (port-status-options :syntax)
+	  (current-port-marker :syntax)
+
+	  maximum-stack-args
+	  maximum-external-call-args
+	  two-byte-nargs-protocol
+	  two-byte-nargs+list-protocol
+	  args+nargs-protocol
+	  big-stack-protocol
+	  nary-dispatch-protocol
+
+	  default-stack-space
+	  environment-stack-size
+	  continuation-stack-size
+	  available-stack-space
+	  ))
+
+; Memory
+
+(define-interface memory-interface
+  (export create-memory memory-begin memory-size
+
+	  bytes-per-cell bits-per-cell
+	  bytes->cells
+	  cells->bytes
+	  a-units->cells
+	  cells->a-units
+	  bytes->a-units
+	  address+ address- address1+ address2+
+	  address-difference
+	  address= address< address<= address> address>=
+	  address->integer integer->address
+
+	  null-address null-address?
+
+	  fetch fetch-byte
+	  store! store-byte!
+
+	  fetch-string fetch-nul-terminated-string
+
+	  copy-memory! memory-equal?    ; from ps-memory
+	  read-block write-block        ; from ps-memory
+	  ))
+
+; Low-level data structures
+
+(define-interface data-interface
+  (export vm-eq?
+	  fixnum? immediate? header? stob?
+
+	  enter-fixnum extract-fixnum
+	  bits-per-fixnum greatest-fixnum-value
+	  too-small-for-fixnum? too-big-for-fixnum?
+	  descriptor->fixnum
+	  fixnum= fixnum< fixnum> fixnum<= fixnum>=
+	  fixnum-bitwise-not fixnum-bitwise-and
+	  fixnum-bitwise-ior fixnum-bitwise-xor
+	  
+	  undefined?
+	  true false eof-object null unspecific-value quiescent
+	  unbound-marker unassigned-marker
+	  vm-boolean? false? enter-boolean extract-boolean
+	  vm-char? enter-char extract-char vm-char=? vm-char<?
+
+	  make-header header-type
+	  header-length-in-bytes header-length-in-cells header-length-in-a-units
+	  immutable-header? make-header-immutable
+	  d-vector-header? b-vector-header?
+	  max-stob-contents-size-in-cells
+
+	  address->stob-descriptor
+	  address-after-header
+	  stob-header stob-header-set!
+	  stob-overhead
+	  ))
+
+(define-interface fixnum-arithmetic-interface
+  (export add-carefully subtract-carefully
+	  multiply-carefully divide-carefully
+	  quotient-carefully remainder-carefully
+	  shift-carefully
+	  abs-carefully
+	  ))
+
+(define-interface stob-interface
+  (export make-d-vector make-b-vector
+          d-vector-length d-vector-ref d-vector-init! d-vector-set!
+	  b-vector-length b-vector-ref b-vector-set!
+	  max-stob-size-in-cells
+
+	  stob-of-type?
+	  header+contents->stob
+	  valid-index?
+	  	
+	  immutable? make-immutable!
+	  ))
+
+(define-interface allocation-interface
+  (export s48-available?
+	  s48-preallocate-space
+	  s48-allocate-space
+	  s48-write-barrier
+          ))
+
+(define-interface heap-interface
+  (export s48-available
+	  s48-heap-size
+
+	  s48-find-all
+	  s48-find-all-records
+
+	  s48-*hp*	; to keep these from being `static' in C, as
+	  s48-*limit*	; references are introduced elsewhere via a C macro
+	  ))
+
+(define heap-gc/image-interface
+  (export swap-spaces
+	  find-resumer-records
+	  heap-start
+	  heap-pointer
+	  heap-limit
+	  set-heap-pointer!
+	  have-static-areas?
+	  walk-impure-areas))
+
+(define-interface interpreter-gc-interface
+  (export collect
+	  collect-saving-temp
+
+	  ensure-space
+	  ensure-space-saving-temp
+	  ensure-space-saving-temps
+
+	  maybe-ensure-space
+	  maybe-ensure-space-saving-temp
+	  maybe-ensure-space-saving-temps
+
+	  add-gc-root!
+	  add-post-gc-cleanup!
+	  ))
+
+(define-interface gc-interface
+  (export s48-trace-value
+	  s48-trace-locations!
+	  s48-trace-stob-contents!
+
+	  s48-begin-collection
+	  s48-do-gc
+	  s48-end-collection
+
+	  s48-extant?
+
+	  s48-gc-count
+	  ))
+
+(define external-opcodes-interface
+  (export ; called from outside
+          s48-define-exported-binding
+	  s48-get-imported-binding
+	  s48-setup-external-exception
+	  s48-resetup-external-exception
+
+	  ; called on startup
+	  s48-warn-about-undefined-imported-bindings
+	  install-shared-bindings!+gc
+	  
+	  ; for writing images
+	  s48-cleaned-imported-bindings
+	  s48-exported-bindings
+	  ))
+
+(define-interface external-gc-roots-interface
+  (export s48-push-gc-roots!
+	  s48-pop-gc-roots!
+	  s48-set-gc-roots-base!
+	  s48-release-gc-roots-base!
+	  s48-register-gc-root!
+
+	  s48-allocate-stob))
+
+(define-interface images-interface
+  (export s48-image-writing-okay?
+	  s48-write-image
+	  s48-check-image-header
+	  s48-read-image
+
+	  s48-startup-procedure
+	  s48-initial-symbols
+	  s48-initial-imported-bindings
+	  s48-initial-exported-bindings
+	  s48-resumer-records
+	  s48-undumpable-records
+
+	  s48-initialization-complete!
+	  s48-initializing-gc-root
+
+	  s48-set-image-values!
+	  ))
+
+(define-interface heap-init-interface
+  (export s48-initialize-heap
+	  s48-register-static-areas
+	  ))
+
+(define-interface string-table-interface
+  (export hash-table-size
+	  hash-table-entry-size
+	  make-hash-table
+	  table-adder
+	  table-searcher
+	  table-remover
+	  table-walker
+	  table-cleaner))
+
+(define-interface struct-interface
+  (export vm-pair? vm-pair-size vm-cons vm-car vm-set-car! vm-cdr vm-set-cdr!
+	  vm-symbol? vm-symbol-size vm-make-symbol vm-symbol->string
+	  vm-symbol-next vm-set-symbol-next!
+	  closure? closure-size make-closure closure-template closure-env
+	  location? location-size make-location contents set-contents! location-id
+	  weak-pointer? weak-pointer-size make-weak-pointer weak-pointer-ref
+
+	  shared-binding? shared-binding-size make-shared-binding
+	  shared-binding-name shared-binding-is-import?
+	  shared-binding-ref shared-binding-set!
+	  shared-binding-next set-shared-binding-next!
+
+	  channel? channel-size make-channel
+	  channel-status    set-channel-status!
+	  channel-id        set-channel-id!
+	  channel-os-index  set-channel-os-index!
+	  channel-next      set-channel-next!
+	  channel-os-status set-channel-os-status!
+	  
+	  port? port-size make-port
+	  port-handler
+	  port-status set-port-status!
+	  port-data set-port-data!
+	  port-buffer set-port-buffer!
+	  port-index set-port-index!
+	  port-limit set-port-limit!
+	  port-lock
+	  port-locked? set-port-locked?!
+	  port-pending-eof? set-port-pending-eof?!
+   
+	  vm-vector? vm-vector-size vm-make-vector vm-vector-length
+	  vm-vector-ref vm-vector-set!
+	  vm-vector-fill!
+
+	  record? record-size make-record record-length
+	  record-ref record-set!
+
+	  extended-number? extended-number-size make-extended-number
+	  extended-number-length
+	  extended-number-ref extended-number-set!
+
+	  continuation? continuation-size make-continuation continuation-length
+	  continuation-ref continuation-set!
+	  continuation-cont     set-continuation-cont!
+	  continuation-pc       set-continuation-pc!
+	  continuation-template set-continuation-template!
+	  continuation-env      set-continuation-env!
+	  continuation-cells
+
+	  code-vector? code-vector-size make-code-vector code-vector-length
+	  code-vector-ref code-vector-set!
+
+	  template? template-size make-template template-length
+	  template-ref template-set!
+	  template-code template-name
+	  make-template-containing-ops op-template-size
+
+	  vm-string? vm-string-size vm-make-string vm-string-length
+	  vm-string-ref vm-string-set!
+	  enter-string extract-string
+	  vm-string=? vm-string-hash
+
+	  bignum? ratnum? double?
+	  ))
+
+(define-interface vmio-interface
+  (export initialize-i/o-system+gc
+
+	  make-registered-channel
+	  s48-add-channel
+	  s48-close-channel
+	  s48-set-channel-os-index
+	  close-channel!
+	  close-channel-index!
+	  os-index->channel
+	  open-channels-list
+
+	  close-untraced-channels!
+	  s48-mark-traced-channels-closed!
+	  trace-io
+
+	  input-channel?
+	  output-channel?
+	  open?
+
+	  channel-queue-empty?
+	  enqueue-channel!
+	  dequeue-channel!
+	  vm-channel-abort
+	  ))
+
+(define-interface environment-interface
+  (export current-env set-current-env!
+	  env-ref env-set! env-parent env-back
+	  pop-args-into-env
+          heap-env-space pop-args-into-heap-env
+	  current-env-size preserve-current-env
+	  ))
+
+(define-interface stack-interface
+  (export initialize-stack+gc
+
+	  reset-stack-pointer stack-size
+	  push pop stack-ref stack-set!
+
+          ensure-stack-space!
+	  ensure-default-procedure-space!
+
+	  push-continuation-on-stack
+	  pop-continuation-from-stack
+
+	  current-continuation-size current-continuation
+	  set-current-continuation!
+	  peek-at-current-continuation skip-current-continuation!
+	  get-continuation-from-heap
+
+	  trace-stack
+
+	  arguments-on-stack
+	  move-args-above-cont!
+	  pointer-to-stack-arguments  ; for calling external procedures
+	  remove-stack-arguments
+
+	  report-continuation-uids
+	  ))
+
+(define-interface external-interface
+  (export extended-vm
+
+	  external-call
+
+	  real-time
+	  run-time
+	  cheap-time
+	  schedule-interrupt
+	  ))
+
+(define-interface event-interface
+  (export initialize-events
+	  get-next-event
+	  wait-for-event
+	  (events :syntax)
+	  ))
+
+(define-interface channel-interface
+  (export current-input-channel
+	  current-output-channel
+	  current-error-channel
+	  input-port->channel
+	  output-port->channel
+	  open-input-file-channel
+	  open-output-file-channel
+	  input-channel->port
+	  output-channel->port
+	  close-input-channel
+	  close-output-channel
+	  channel-read-block
+	  channel-write-block
+	  channel-abort
+	  ))
+
+(define external-call-interface
+  (export ; called from outside
+          s48-define-exported-binding
+	  s48-get-imported-binding
+	  s48-setup-external-exception
+	  s48-resetup-external-exception
+
+	  ; called on startup
+	  s48-warn-about-undefined-imported-bindings
+	  install-shared-bindings!+gc
+	  
+	  ; for writing images
+	  s48-cleaned-imported-bindings
+	  s48-exported-bindings
+	  ))
+
+(define-interface interpreter-internal-interface
+  (export ((define-primitive define-consing-primitive) :syntax)
+
+	  ((raise-exception raise-exception*) :syntax)
+	  raise
+	  push-exception-continuation!
+
+	  any-> string-> fixnum-> boolean->
+	  input-type no-coercion
+	  
+	  no-result
+	  return
+	  return-fixnum
+	  return-boolean
+	  return-unspecific
+	  continue
+	  continue-with-value
+
+	  code-byte
+	  val set-val!
+	  code-pointer set-code-pointer!
+	  current-thread
+	  disable-interrupts!
+	  enable-interrupts!
+	  s48-set-os-signal
+
+	  s48-*callback-return-stack-block*
+	  ))
+
+(define-interface interpreter-interface
+  (export initialize-interpreter+gc
+	  clear-registers
+	  interpret
+	  s48-set-extension-value!
+	  s48-note-event
+	  s48-*extension-value*
+	  s48-*pending-events?*
+	  s48-*pending-interrupt?*
+	  ))
+
+; What the external world can call.  Because of C's flat namespace we have
+; added s48_ to the front of each of these.
+
+(define-interface vm-interface
+  (export s48-initialize-vm
+	  s48-call-startup-procedure
+
+	  s48-restart
+
+	  s48-set-extension-value!
+	  s48-*extension-value*
+
+	  s48-note-event
+	  s48-*pending-events?*
+	  s48-*pending-interrupt?*
+          s48-disable-interrupts!
+          s48-enable-interrupts!
+	  s48-set-os-signal
+	  
+          s48-define-exported-binding
+	  s48-get-imported-binding
+
+	  s48-*callback-return-stack-block*
+
+	  ; used for raising exceptions in external code
+	  s48-setup-external-exception
+	  s48-resetup-external-exception
+	  s48-push
+	  s48-stack-ref s48-stack-set!
+
+	  ; called when writing an image
+	  s48-copy-symbol-table
+	  s48-mark-traced-channels-closed!
+	  s48-cleaned-imported-bindings
+	  s48-exported-bindings
+
+	  ; called when resuming an image
+	  s48-warn-about-undefined-imported-bindings
+
+	  ; for C code that wants to manipulate channels
+	  s48-close-channel
+	  s48-add-channel
+	  s48-set-channel-os-index
+	  ))
diff --git a/scheme/vm/interp-gc.scm b/scheme/vm/interp-gc.scm
new file mode 100644
index 0000000..47191a6
--- /dev/null
+++ b/scheme/vm/interp-gc.scm
@@ -0,0 +1,107 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; Different ways to call the GC, depending on how many temporaries need to
+; be traced.
+
+; ENSURE-SPACE and friends make sure that there is at least SPACE remaining
+; in the heap, triggering a GC if necessary.  A key to the pre-allocated space
+; is returned (keys and pre-allocation are described in heap.scm).  If SPACE
+; is not available, even after a GC, we kill the process.
+
+(define (ensure-space space)
+  (receive (key temp)
+      (ensure-space-saving-temp space false)
+    key))
+
+(define (ensure-space-saving-temp space temp)
+  (receive (okay? key temp ignore)
+      (maybe-ensure-space-saving-temps space temp false)
+    (if (not okay?)
+	(error "Scheme48 heap overflow"))
+    (values key temp)))
+
+(define (ensure-space-saving-temps space temp0 temp1)
+  (receive (okay? key temp0 temp1)
+      (maybe-ensure-space-saving-temps space temp0 temp1)
+    (if (not okay?)
+	(error "Scheme48 heap overflow"))
+    (values key temp0 temp1)))
+
+; Same thing, except that we return a flag instead of dying if the space is
+; not available.
+
+(define (maybe-ensure-space space)
+  (receive (okay? key ignore0 ignore1)
+      (maybe-ensure-space-saving-temps space false false)
+    (values okay? key)))
+
+(define (maybe-ensure-space-saving-temp space temp)
+  (receive (okay? key temp ignore0)
+      (maybe-ensure-space-saving-temps space temp false)
+    (values okay? key temp)))
+
+(define (maybe-ensure-space-saving-temps space temp0 temp1)
+  (if (s48-available? space)
+      (values #t (s48-preallocate-space space) temp0 temp1)
+      (receive (temp0 temp1)
+	  (collect-saving-temps temp0 temp1)
+	(if (s48-available? space)
+	    (values #t (s48-preallocate-space space) temp0 temp1)
+	    (values #f 0 temp0 temp1)))))
+
+;----------------
+; The GC itself, with versions that handle one or two temporaries.
+
+(define (collect)
+  (receive (ignore0 ignore1)
+      (collect-saving-temps (enter-fixnum 0) (enter-fixnum 0))
+    0))  ; type checker rejected (values) here; why?
+
+(define (collect-saving-temp value)
+  (receive (value ignore1)
+      (collect-saving-temps value (enter-fixnum 0))
+    value))
+
+; This is a front for the real GC, which is a separate program.  All that the
+; interpreter contributes is the root set and some post-gc cleanup code.
+
+(define (collect-saving-temps value0 value1)
+  (s48-begin-collection)
+  (gc-root)
+  (let ((value0 (s48-trace-value value0))
+	(value1 (s48-trace-value value1)))
+    (s48-do-gc)
+    (post-gc-cleanup)
+    (s48-end-collection)
+    (values value0 value1)))
+
+;----------------
+; GC-ROOT and POST-GC-CLEANUP are defined incrementally.
+;
+; (ADD-GC-ROOT! <thunk>)           ; call <thunk> when tracing the GC roots
+; (ADD-POST-GC-CLEANUP! <thunk>)   ; call <thunk> when a GC has finished
+;
+; (GC-ROOT)                        ; call all the root thunks
+; (POST-GC-CLEANUP)                ; call all the cleanup thunks
+
+(define-syntax define-extensible-proc
+  (syntax-rules ()
+    ((define-extensible-proc proc extender temp)
+     (begin
+       (define temp unspecific)
+       (define (proc) (temp))
+       (define (extender more)
+	 (let ((old temp))
+	   (set! temp (lambda ()
+			(more)
+			(old)))))))))
+
+(define-extensible-proc gc-root
+  add-gc-root!
+  *gc-root-proc*)
+
+(define-extensible-proc post-gc-cleanup
+  add-post-gc-cleanup!
+  *post-gc-cleanup*)
+
diff --git a/scheme/vm/interp.scm b/scheme/vm/interp.scm
new file mode 100644
index 0000000..48938d3
--- /dev/null
+++ b/scheme/vm/interp.scm
@@ -0,0 +1,699 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+;Need to fix the byte-code compiler to make jump etc. offsets from the
+;beginning of the instruction.
+
+; This is file interp.scm.
+
+; Interpreter state
+
+(define *template*)		; current template
+(define *code-pointer*)		; pointer to next instruction byte
+(define *val*)			; last value produced
+(define *exception-handlers*)	; vector of procedures, one per opcode
+(define *interrupt-handlers*)	; vector of procedures, one per interrupt type
+
+; Two registers used only by the RTS (except for one hack; see GET-CURRENT-PORT
+; in prim-io.scm).
+
+(define *current-thread*)	; dynamic state
+(define *session-data*)		; session state
+
+; Finalizers
+
+(define *finalizer-alist*)	; list of (<thing> . <procedure>) pairs
+(define *finalize-these*)	; list of such pairs that should be executed
+
+; Interrupts
+
+(define *enabled-interrupts*)	; bitmask of enabled interrupts
+(define *pending-interrupts*)	; bitmask of pending interrupts
+(define s48-*pending-interrupt?*) ; true if an interrupt is pending
+
+(define *interrupted-template*) ; template in place when the most recent
+				; interrupt occured - for profiling
+
+(define *interrupt-template*)	; used to return from interrupts
+(define *exception-template*)	; used to mark exception continuations
+
+; These are referred to from other modules.
+
+(define (val) *val*)
+(define (set-val! val) (set! *val* val))
+(define (code-pointer) *code-pointer*)
+(define (current-thread) *current-thread*)
+
+;----------------
+
+(define (clear-registers)
+  (reset-stack-pointer false)
+  (set-current-env! unspecific-value)
+  (set-template! *interrupt-template*          ; has to be some template
+		 (enter-fixnum 0))
+  (set! *val*                unspecific-value)
+  (set! *current-thread*     null)
+  (set! *session-data*       null)
+  (set! *exception-handlers* null)
+  (set! *interrupt-handlers* null)
+  (set! *enabled-interrupts* 0)
+  (set! *finalizer-alist*    null)
+  (set! *finalize-these*     null)
+
+  (set! *pending-interrupts* 0)
+  (set! s48-*pending-interrupt?* #f)
+  (set! *interrupted-template* false)
+  unspecific-value)
+
+(define *saved-pc*)	; for saving the pc across GC's
+
+(add-gc-root!
+  (lambda ()
+    (set! *saved-pc* (current-pc))    ; headers may be busted here...
+
+    (set! *template*             (s48-trace-value *template*))
+    (set! *val*                  (s48-trace-value *val*))
+    (set! *current-thread*       (s48-trace-value *current-thread*))
+    (set! *session-data*         (s48-trace-value *session-data*))
+    (set! *exception-handlers*   (s48-trace-value *exception-handlers*))
+    (set! *exception-template*   (s48-trace-value *exception-template*))
+    (set! *interrupt-handlers*   (s48-trace-value *interrupt-handlers*))
+    (set! *interrupt-template*   (s48-trace-value *interrupt-template*))
+    (set! *interrupted-template* (s48-trace-value *interrupted-template*))
+    (set! *finalize-these*       (s48-trace-value *finalize-these*))
+    (set! *os-signal-type*       (s48-trace-value *os-signal-type*))
+    (set! *os-signal-argument*   (s48-trace-value *os-signal-argument*))
+    (trace-finalizer-alist!)
+    
+    ; These could be moved to the appropriate modules.
+    (set-current-env! (s48-trace-value (current-env)))
+    (trace-io s48-trace-value)
+    (trace-stack s48-trace-locations! s48-trace-stob-contents! s48-trace-value)))
+
+(add-post-gc-cleanup!
+  (lambda ()
+    (set-template! *template* *saved-pc*)
+    (partition-finalizer-alist!)
+    (close-untraced-channels!)
+    (note-interrupt! (enum interrupt post-gc))))
+
+;----------------
+; Dealing with the list of finalizers.
+;
+; Pre-gc:
+;  Trace the contents of every finalizer object, updating them in oldspace.
+;  If any contains a pointer to itself, quit and trace it normally.
+;  If any have already been copied, ignore it.
+; Post-gc:
+;  Check each to see if each has been copied.  If not, copy it.  There is
+;  no need to trace any additional pointers.
+
+; Walk down the finalizer alist, tracing the procedures and the contents of
+; the things.
+
+(define (trace-finalizer-alist!)
+  (let loop ((alist *finalizer-alist*))
+    (if (not (vm-eq? alist null))
+	(let* ((pair (vm-car alist)))
+	  (if (not (s48-extant? (vm-car pair)))  ; if not already traced
+	      (s48-trace-stob-contents! (vm-car pair)))
+	  (vm-set-cdr! pair (s48-trace-value (vm-cdr pair)))
+	  (loop (vm-cdr alist))))))
+
+; Walk down the finalizer alist, separating out the pairs whose things
+; have been copied.
+
+(define (partition-finalizer-alist!)
+  (let loop ((alist *finalizer-alist*) (okay null) (goners null))
+    (if (vm-eq? alist null)
+	(begin
+	  (set! *finalizer-alist* okay)
+	  (set! *finalize-these* (vm-append! goners *finalize-these*)))
+	(let* ((alist (s48-trace-value alist))
+	       (pair (s48-trace-value (vm-car alist)))
+	       (thing (vm-car pair))
+	       (next (vm-cdr alist))
+	       (traced? (s48-extant? thing)))
+	  (vm-set-car! pair (s48-trace-value thing))
+	  (vm-set-car! alist pair)
+	  (cond (traced?
+		 (vm-set-cdr! alist okay)
+		 (loop next alist goners))
+		(else
+		 (vm-set-cdr! alist goners)
+		 (loop next okay alist)))))))
+
+(define (vm-append! l1 l2)
+  (if (vm-eq? l1 null)
+      l2
+      (let ((last-pair (let loop ((l l1))
+			 (if (vm-eq? (vm-cdr l) null)
+			     l
+			     (loop (vm-cdr l))))))
+	(vm-set-cdr! last-pair l2)
+	l1)))
+
+;----------------
+
+(define (set-template! tem pc)
+  (set! *template* tem)
+  (set-code-pointer! (template-code tem) (extract-fixnum pc)))
+
+(define (set-code-pointer! code pc)
+  (set! *code-pointer* (address+ (address-after-header code) pc)))
+
+(define (code-pointer->pc pointer template)
+  (enter-fixnum (address-difference
+		  pointer
+		  (address-after-header (template-code template)))))
+
+(define (current-pc)
+  (code-pointer->pc *code-pointer* *template*))
+
+(define (initialize-interpreter+gc)          ;Used only at startup
+  (let ((key (ensure-space (op-template-size 2))))
+    (set! *interrupt-template*
+	  (make-template-containing-ops (enum op ignore-values)
+					(enum op return-from-interrupt)
+					key))
+    (set! *exception-template*
+	  (make-template-containing-ops (enum op return-from-exception)
+					(enum op false)     ; ignored
+					key))))
+
+;----------------
+; Continuations
+
+(define (push-continuation! code-pointer size)
+  (let ((pc (code-pointer->pc code-pointer *template*)))
+    (push-continuation-on-stack *template* pc size)))
+
+(define (pop-continuation!)
+  (pop-continuation-from-stack set-template!))
+  
+;----------------
+; Instruction stream access
+
+(define (code-byte index)
+  (fetch-byte (address+ *code-pointer* (+ index 1))))
+
+(define (code-offset index)
+  (adjoin-bits (code-byte index)
+	       (code-byte (+ index 1))
+	       bits-used-per-byte))
+
+(define (get-literal index)
+  (template-ref *template* (code-offset index)))
+
+; Return the current op-code.  CODE-ARGS is the number of argument bytes that
+; have been used.
+
+(define (current-opcode)
+  (code-byte -1))
+
+; INTERPRET is the main instruction dispatch for the interpreter.
+
+;(define trace-instructions? #f)
+;(define *bad-count* 0)
+;(define *i* 0)
+
+(define (interpret code-pointer)
+;  (if (and trace-instructions? (> *i* *bad-count*))
+;      (write-instruction *template* (extract-fixnum (current-pc)) 1 #f))
+;  (set! *i* (+ *i* 1))
+  ((vector-ref opcode-dispatch (fetch-byte code-pointer))))
+
+(define (continue bytes-used)
+  (set! *code-pointer* (address+ *code-pointer* (+ bytes-used 1)))
+  (goto interpret *code-pointer*))
+
+(define (continue-with-value value bytes-used)
+  (set! *val* value)
+  (goto continue bytes-used))
+
+;----------------
+; Opcodes
+
+(define (uuo)
+  (raise-exception unimplemented-instruction 0))
+
+(define opcode-dispatch (make-vector op-count))
+
+(vector+length-fill! opcode-dispatch op-count uuo)
+
+(define-syntax define-opcode
+  (syntax-rules ()
+    ((define-opcode op-name body ...)
+     (vector-set! opcode-dispatch (enum op op-name) (lambda () body ...)))))
+
+;----------------
+; Exception syntax
+
+; For restartable exceptions the saved code-pointer points to the instruction
+; following the offending one.  For all other exceptions it points to the
+; offending instruction.
+;
+; The ...* versions evaluate the exception enum argument, the plain ones
+; invoke the enumeration.
+
+(define-syntax raise-exception
+  (syntax-rules ()
+    ((raise-exception why byte-args stuff ...)
+     (raise-exception* (enum exception why) byte-args stuff ...))))
+
+(define-syntax count-exception-args
+  (syntax-rules ()
+    ((count-exception-args) 0)
+    ((count-exception-args arg1 rest ...)
+     (+ 1 (count-exception-args rest ...)))))
+
+(define-syntax raise-exception*
+  (syntax-rules ()
+    ((raise-exception* why byte-args arg1 ...)
+     (begin
+       (push-exception-continuation! why (+ byte-args 1)) ; add 1 for the opcode
+       (push arg1) ...
+       (goto raise (count-exception-args arg1 ...))))))
+
+;----------------
+; Exceptions
+
+; The system reserves enough stack space to allow for an exception at any time.
+; If the reserved space is used a gc must be done before the exception handler
+; is called.
+
+; New exception handlers in *val*.
+
+(define-opcode set-exception-handlers!
+  (cond ((or (not (vm-vector? *val*))
+	     (< (vm-vector-length *val*) op-count))
+	 (raise-exception wrong-type-argument 0 *val*))
+	(else
+	 (let ((temp *exception-handlers*))
+	   (set! *exception-handlers* *val*)
+	   (goto continue-with-value
+		 temp
+		 0)))))
+
+; The current opcode and the exception are pushed as arguments to the handler.
+; INSTRUCTION-SIZE is the size of the current instruction and is used to jump
+; to the next instruction when returning.  The exception is saved in the
+; continuation for use in debugging.
+
+(define (push-exception-continuation! exception instruction-size)
+  (let ((opcode (current-opcode)))
+    (push (enter-fixnum instruction-size))
+    (push (enter-fixnum exception))
+    (push *template*)
+    (push (current-pc))
+    (set-template! *exception-template* (enter-fixnum 0))
+    (push-continuation! *code-pointer* (arguments-on-stack))
+    (push (enter-fixnum opcode))
+    (push (enter-fixnum exception))))
+
+(define-opcode return-from-exception
+  (let* ((pc (extract-fixnum (pop)))
+	 (template (pop))
+	 (exception (pop))	; ignored
+	 (size (extract-fixnum (pop))))
+    (set-template! template (enter-fixnum (+ pc size)))
+    (goto interpret *code-pointer*)))
+
+;(define no-exceptions? #t)
+
+(define (raise nargs)
+;  (let ((opcode (enumerand->name (extract-fixnum (stack-ref (+ nargs 1))) op))
+;	(why (enumerand->name (extract-fixnum (stack-ref nargs)) exception)))
+;    (if (and no-exceptions?
+;             (not (and (eq? 'write-char opcode)
+;                       (eq? 'buffer-full/empty why))))
+;        (breakpoint "exception check ~A ~A ~A" opcode why nargs)))
+  ;; try to be helpful when all collapses
+  (let* ((opcode (extract-fixnum (stack-ref (+ nargs 1))))
+	 (lose (lambda (message)
+		(let ((why (extract-fixnum (stack-ref nargs))))
+		  (write-string "Template UIDs: " (current-error-port))
+		  (report-continuation-uids *template* (current-error-port))
+		  (newline (current-error-port))
+		  (if (and (eq? why (enum exception undefined-global))
+			   (fixnum? (location-id (stack-ref (- nargs 1)))))
+		      (error message opcode why
+			     (extract-fixnum (location-id (stack-ref (- nargs 1)))))
+		      (error message opcode why))))))
+    (if (not (vm-vector? *exception-handlers*))
+	(lose "exception-handlers is not a vector"))
+    (set! *val* (vm-vector-ref *exception-handlers* opcode))
+    (if (not (closure? *val*))
+	(lose "exception handler is not a closure"))
+    (goto call-exception-handler (+ nargs 2) opcode)))
+
+;----------------
+; Literals
+; Loaded from *template* into *val*, using either a one-byte or two-byte index.
+
+(define-opcode literal    ;Load a literal into *val*.
+  (goto continue-with-value
+	(get-literal 0)
+	2)) ; offset
+
+(define-opcode small-literal
+  (goto continue-with-value
+	(template-ref *template* (code-byte 0))
+	2)) ; byte + wasted byte
+
+;----------------
+; Environment creation
+;  The MAKE-ENV instruction adds a env to the local environment.
+; It pops values off the stack and stores them into the new env.
+
+(define-opcode make-env
+  (pop-args-into-env (code-offset 0))
+  (goto continue 2)) ; offset
+
+; Local variable access and assignment
+
+(define-opcode local      ;Load value of a local.
+  (goto finish-local (env-back (current-env) (code-byte 0)) 1))
+
+(define-opcode local0
+  (goto finish-local (current-env) 0))
+
+(define-opcode push-local0
+  (push *val*)
+  (goto finish-local (current-env) 1))
+
+(define-opcode local0-push
+  (set! *val* (env-ref (current-env) (code-byte 0)))
+  (if (not (vm-eq? *val* unassigned-marker))
+      (begin
+	(push *val*)
+	(goto continue 2))
+      (raise-exception unassigned-local 2)))
+
+(define-opcode local1
+  (goto finish-local (env-parent (current-env)) 0))
+
+(define-opcode local2
+  (goto finish-local (env-parent (env-parent (current-env))) 0))
+
+(define (finish-local env arg-count)
+  (set! *val* (env-ref env (code-byte arg-count)))
+  (if (not (vm-eq? *val* unassigned-marker))
+      (goto continue (+ arg-count 1))
+      (raise-exception unassigned-local (+ arg-count 1))))
+
+(define-opcode big-local
+  (let ((back (code-offset 0)))
+    (set! *val* (env-ref (env-back (current-env) back)
+			 (code-offset 2)))
+    (if (not (vm-eq? *val* unassigned-marker))
+	(goto continue 4) ; byte + offset
+	(raise-exception unassigned-local 4))))
+
+(define-opcode set-local!
+  (let ((back (code-offset 0)))
+    (env-set! (env-back (current-env) back)
+              (code-offset 2)
+              *val*)
+    (set! *val* unspecific-value)
+    (goto continue 4))) ; byte + offset
+
+;----------------
+; Global variable access
+
+(define-opcode global        ;Load a global variable.
+  (let ((location (get-literal 0)))
+    (set! *val* (contents location))
+    (if (undefined? *val*)           ;unbound or unassigned
+	(raise-exception undefined-global 2 location)
+	(goto continue 2)))) ; offset
+
+(define-opcode set-global!
+  (let ((location (get-literal 0)))
+    (cond ((vm-eq? (contents location) unbound-marker)
+           (raise-exception undefined-global 2 location *val*))
+          (else
+           (set-contents! location *val*)
+	   (goto continue-with-value
+		 unspecific-value
+		 2))))) ; offset
+
+;----------------
+; Stack operation
+
+(define-opcode push	;Push *val* onto the stack.
+  (push *val*)
+  (goto continue 0))
+
+(define-opcode pop	;Pop *val* from the stack.
+  (goto continue-with-value
+	(pop)
+	0))
+
+(define-opcode stack-ref
+  (goto continue-with-value
+	(stack-ref (code-byte 0))
+	1))
+
+(define-opcode stack-set!
+  (stack-set! (code-byte 0) *val*)
+  (goto continue 1))
+
+;----------------
+; LAMBDA
+
+(define-opcode closure
+  (let ((env (if (= 0 (code-byte 2))
+		 (preserve-current-env (ensure-space (current-env-size)))
+		 *val*)))
+    (receive (key env)
+	(ensure-space-saving-temp closure-size env)
+      (goto continue-with-value
+	    (make-closure (get-literal 0) env key)
+	    3))))
+
+; Looks like:
+; (enum op make-flat-env)
+; number of vars
+; use *val* as first element?
+; depth of first level
+; number of vars in level
+; offsets of vars in level
+; delta of depth of second level
+; ...
+
+(define-opcode make-flat-env
+  (let* ((total-count (code-byte 1))
+	 (new-env (vm-make-vector total-count
+				  (ensure-space (vm-vector-size total-count))))
+	 (start-i (if (= 0 (code-byte 0))
+		      0
+		      (begin
+			(vm-vector-set! new-env 0 *val*)
+			1))))
+    (let loop ((i start-i)
+	       (offset 2)		; count and use-*val*
+	       (env (current-env)))
+      (if (= i total-count)
+	  (goto continue-with-value
+		new-env
+		offset)
+	  (let ((env (env-back env (code-byte offset)))
+		(count (code-byte (+ offset 1))))
+	    (do ((count count (- count 1))
+		 (i i (+ i 1))
+		 (offset (+ offset 2) (+ offset 1)))	; env-back and count
+		((= count 0)
+		 (loop i offset env))
+	      (vm-vector-set! new-env
+			      i
+			      (vm-vector-ref env
+					     (code-byte offset)))))))))
+
+;----------------
+; Continuation creation and invocation
+
+(define-opcode make-cont   ;Start a non-tail call.
+  (push-continuation! (address+ *code-pointer*
+				(code-offset 0))
+		      (code-byte 2))
+  (goto continue 3))
+
+(define-opcode make-big-cont   ;Start a non-tail call.
+  (push-continuation! (address+ *code-pointer*
+				(code-offset 0))
+		      (code-offset 2))
+  (goto continue 4))
+
+(define-opcode return            ;Invoke the continuation.
+  (pop-continuation!)
+  (goto interpret *code-pointer*))
+
+; This is only used in the closed-compiled version of VALUES.
+; Stack is: arg0 arg1 ... argN rest-list N+1 total-arg-count.
+; If REST-LIST is non-empty then there are at least two arguments on the stack.
+
+(define-opcode closed-values
+  (let* ((nargs (extract-fixnum (pop)))
+	 (stack-nargs (extract-fixnum (pop)))
+	 (rest-list (pop)))
+    (goto return-values stack-nargs rest-list (- nargs stack-nargs))))
+
+; Same as the above, except that the value count is in the instruction stream
+; and all of the arguments are on the stack.
+; This is used for in-lining calls to VALUES.
+
+(define-opcode values
+  (goto return-values (code-offset 0) null 0))
+
+; STACK-NARGS return values are on the stack.  If there is only one value, pop
+; it off and do a normal return.  Otherwise, find the actual continuation
+; and see if it ignores the values, wants the values, or doesn't know
+; anything about them.
+
+(define (return-values stack-nargs list-args list-arg-count)
+  (cond ((= stack-nargs 1)  ; if list-arg-count > 0 then stack-nargs > 1
+	 (set! *val* (pop))
+	 (pop-continuation!)
+	 (goto interpret *code-pointer*))
+	(else
+	 (let ((cont (peek-at-current-continuation)))
+	   (if (continuation? cont)
+	       (goto really-return-values
+		     cont stack-nargs list-args list-arg-count)
+	       (goto return-exception stack-nargs list-args))))))
+	 
+; If the next op-code is:
+; op/ignore-values - just return, ignoring the return values
+; op/call-with-values - remove the continuation containing the consumer
+;  (the consumer is the only useful information it contains), and then call
+;  the consumer.
+; anything else - only one argument was expected so raise an exception.
+
+(define (really-return-values cont stack-nargs list-args list-arg-count)
+  (let ((next-op (code-vector-ref (template-code (continuation-template cont))
+				  (extract-fixnum (continuation-pc cont)))))
+    (cond ((= next-op (enum op ignore-values))
+	   (pop-continuation!)
+	   (goto interpret *code-pointer*))
+	  ((= next-op (enum op call-with-values))
+	   (skip-current-continuation!)
+	   (set! *val* (continuation-ref cont continuation-cells))
+	   (goto perform-application-with-rest-list stack-nargs
+		                                    list-args
+						    list-arg-count))
+	  (else
+	   (goto return-exception stack-nargs list-args)))))
+
+; This would avoid the need for the consumer to be a closure.  It doesn't
+; work because the NARGS check (which would be the next instruction to be
+; executed) assumes that a closure has just been called.
+
+;(define (do-call-with-values nargs)
+;  (cond ((address= *cont* *bottom-of-stack*)
+;	 (restore-from-continuation (continuation-cont *cont*))
+;	 (set-continuation-cont! *bottom-of-stack* *cont*)
+;	 (set! *cont* *bottom-of-stack*))
+;	(else
+;	 (restore-from-continuation cont)))
+;  (set! *code-pointer* (address+ *code-pointer* 1)) ; move past (enum op call-with-values
+;)  (goto interpret *code-pointer*))
+
+(define (return-exception stack-nargs list-args)
+  (let ((args (pop-args->list* list-args stack-nargs)))
+    (raise-exception wrong-number-of-arguments -1 false args))) ; no next opcode
+
+; This is executed only if the producer returned exactly one value.
+
+(define-opcode call-with-values
+  (let ((consumer (pop)))
+    (push *val*)
+    (set! *val* consumer)
+    (goto perform-application 1)))
+
+; This is just a marker for the code that handles returns.
+
+(define-opcode ignore-values
+  (goto continue 0))
+
+;----------------
+; Preserve the current continuation and put it in *val*.
+
+(define-opcode current-cont
+  (let ((key (ensure-space (current-continuation-size))))
+    (goto continue-with-value
+	  (current-continuation key)
+	  0)))
+
+(define-opcode with-continuation
+  (set-current-continuation! (pop))
+  (goto perform-application 0))
+
+; only used in the stack underflow template
+
+(define-opcode get-cont-from-heap
+  (let ((cont (get-continuation-from-heap)))
+    (cond ((continuation? cont)
+	   (set-current-continuation! cont)
+	   (goto continue 0))
+	  ((and (false? cont)
+		(fixnum? *val*))			  ; VM returns here
+	   (set! s48-*callback-return-stack-block* false) ; not from a callback
+	   (extract-fixnum *val*))
+	  (else
+	   (set-current-continuation! false)
+	   (raise-exception wrong-type-argument 0 *val* cont)))))
+
+;----------------
+; Control flow
+
+; IF
+
+(define-opcode jump-if-false
+  (cond ((false? *val*)
+	 (set! *code-pointer*
+	       (address+ *code-pointer*
+			 (code-offset 0)))
+	 (goto interpret *code-pointer*))
+	(else
+	 (goto continue 2))))
+
+; Unconditional jump
+
+(define-opcode jump
+  (set! *code-pointer*
+	(address+ *code-pointer*
+		  (code-offset 0)))
+  (goto interpret *code-pointer*))
+
+; Computed goto
+; Goto index is in *val*, the next byte is the number of offsets specified
+; The default is to jump to the instruction following the offsets
+; The instruction stream looks like
+; op/computed-goto max offset0 offset1 ... offsetmax-1 code-for-default...
+
+(define-opcode computed-goto
+  (if (not (fixnum? *val*))
+      (raise-exception wrong-type-argument -1 *val*)  ; back up over opcode
+      (let ((max (code-byte 0))
+	    (val (extract-fixnum *val*)))
+	(let ((offset (if (and (>= val 0)
+			       (< val max))
+			  (code-offset (+ (* val 2) 1))
+			  (+ (* max 2) 2))))
+	  (set! *code-pointer* (address+ *code-pointer* offset))
+	  (goto interpret *code-pointer*)))))
+
+;----------------
+; Miscellaneous primitive procedures
+
+(define-opcode unassigned
+  (goto continue-with-value
+	unassigned-marker
+	0))
+
+(define-opcode unspecific
+  (goto continue-with-value
+	unspecific-value
+	0))
+
diff --git a/scheme/vm/interrupt.scm b/scheme/vm/interrupt.scm
new file mode 100644
index 0000000..a13507f
--- /dev/null
+++ b/scheme/vm/interrupt.scm
@@ -0,0 +1,257 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+; Code for handling interrupts.
+
+; New interrupt handler vector in *val*
+
+(define-opcode set-interrupt-handlers!
+  (cond ((or (not (vm-vector? *val*))
+	     (< (vm-vector-length *val*) interrupt-count))
+	 (raise-exception wrong-type-argument 0 *val*))
+	(else
+	 (let ((temp *interrupt-handlers*))
+	   (set! *interrupt-handlers* *val*)
+	   (set! *val* temp)
+	   (goto continue 0)))))
+
+; New interrupt mask as fixnum in *val*
+
+(define-opcode set-enabled-interrupts!
+  (let ((old *enabled-interrupts*))
+    (set-enabled-interrupts! (extract-fixnum *val*))
+    (set! *val* (enter-fixnum old))
+    (goto continue 0)))
+
+; Save the current interpreter state and call an interrupt handler.
+
+(define (handle-interrupt stack-arg-count)
+  (push *val*)
+  (push *template*)
+  (push (current-pc))
+  (push (enter-fixnum *enabled-interrupts*))
+  (set-template! *interrupt-template* (enter-fixnum 0))
+  (push-continuation! *code-pointer* (+ stack-arg-count 4))
+  (let* ((pending-interrupt (get-highest-priority-interrupt!))
+	 (arg-count (push-interrupt-args pending-interrupt)))
+    (if (not (vm-vector? *interrupt-handlers*))
+	(error "interrupt handler is not a vector"))
+    (set-enabled-interrupts! 0)
+    (set! *val* (vm-vector-ref *interrupt-handlers* pending-interrupt))
+    (if (not (closure? *val*))
+	(error "interrupt handler is not a closure" pending-interrupt))
+    (goto call-interrupt-handler arg-count pending-interrupt)))
+
+; Push the correct arguments for each type of interrupt.
+;
+; For alarm interrupts the interrupted template is passed to the handler
+;  for use by code profilers.
+; For gc interrupts we push the list of things to be finalized.
+; For i/o-completion we push the channel and its status.
+
+(define (push-interrupt-args pending-interrupt)
+  (cond ((eq? pending-interrupt (enum interrupt alarm))
+	 (push *interrupted-template*)
+	 (set! *interrupted-template* false)
+	 (push (enter-fixnum *enabled-interrupts*))
+	 2)
+	((eq? pending-interrupt (enum interrupt post-gc))
+	 (push *finalize-these*)
+	 (set! *finalize-these* null)
+	 (push (enter-fixnum *enabled-interrupts*))
+	 2)
+	((eq? pending-interrupt (enum interrupt i/o-completion))
+	 (let ((channel (dequeue-channel!)))
+	   (if (not (channel-queue-empty?))
+	       (note-interrupt! (enum interrupt i/o-completion)))
+	   (push channel)
+	   (push (channel-os-status channel))
+	   (push (enter-fixnum *enabled-interrupts*))
+	   3))
+	((eq? pending-interrupt (enum interrupt os-signal))
+	 (push *os-signal-type*)
+	 (push *os-signal-argument*)
+	 (set! *os-signal-type* false)
+	 (set! *os-signal-argument* false)
+	 (push (enter-fixnum *enabled-interrupts*))
+	 3)
+	(else
+	 (push (enter-fixnum *enabled-interrupts*))
+	 1)))
+
+; Called from outside when an os-signal event is returned.
+
+(define (s48-set-os-signal type argument)
+  (set! *os-signal-type* type)
+  (set! *os-signal-argument* argument))
+
+(define *os-signal-type* false)
+(define *os-signal-argument* false)
+
+; Return from a call to an interrupt handler.
+
+(define-opcode return-from-interrupt
+  (set-enabled-interrupts! (extract-fixnum (pop)))
+  (let ((pc (pop)))
+    (set-template! (pop) pc))
+  (set! *val* (pop))
+  (goto interpret *code-pointer*))
+
+; Do nothing much until something happens.  To avoid race conditions this
+; opcode is called with all interrupts disabled, so it has to return if
+; any interrupt occurs, even a disabled one.
+
+(define-primitive wait (fixnum-> boolean->)
+  (lambda (max-wait minutes?)
+    (if (not (any-pending-interrupts?))
+	(wait-for-event max-wait minutes?))
+    (goto return-unspecific 0)))
+
+; The players:
+;   *pending-interrupts*      A bit mask of pending interrupts
+;   *enabled-interrupts*      A bit mask of enabled interrupts
+;   s48-*pending-interrupt?*  True if either an event or interrupt is pending
+;   s48-*pending-events?*     True if an event is pending
+;
+; When an asynchronous event occurs the OS sets S48-*PENDING-EVENTS?* and
+; S48-*PENDING-INTERRUPT?* to true.
+;
+; When S48-*PENDING-EVENTS?* is true the VM calls (CURRENT-EVENTS) to get the
+; pending events.
+;
+; The goals of all this mucking about are:
+;   - no race conditions
+;   - the VM operates synchronously; only the OS is asynchronous
+;   - polling only requires testing S48-*PENDING-INTERRUPT?*
+
+(define s48-*pending-events?* #f)
+
+; Called asynchronously by the OS
+
+(define (s48-note-event)
+  (set! s48-*pending-events?* #t)       ; order required by non-atomicity
+  (set! s48-*pending-interrupt?* #t))
+
+; The polling procedure.  If *PENDING-INTERRUPT* then either there is a
+; pending OS event or there is really a pending interrupt.  CHECK-EVENTS
+; ends with a call to PENDING-INTERRUPT? (we don't call it here because
+; we want this procedure to be small so that it will compiled in-line).
+
+(define (pending-interrupt?)
+  (cond ((not s48-*pending-interrupt?*)
+	 #f)
+	(s48-*pending-events?*
+	 (set! s48-*pending-events?* #f)
+	 (check-events))  ; ends with call to PENDING-INTERRUPT?
+	(else
+	 #t)))
+
+; Same, except we include disabled interrupts.
+
+(define (any-pending-interrupts?)
+  (or (pending-interrupt?)
+      (not (= 0 *pending-interrupts*))))
+
+; Add INTERRUPT to the set of pending interrupts, then check to see if it
+; is currently pending.
+
+(define (note-interrupt! interrupt)
+  (set! *pending-interrupts*
+	(bitwise-ior *pending-interrupts* (interrupt-bit interrupt)))
+  (check-for-enabled-interrupt!))
+
+; Remove INTERRUPT from the set of pending interrupts, then recheck for pending
+; interrupts; INTERRUPT may have been the only one.
+
+(define (clear-interrupt! interrupt)
+  (set! *pending-interrupts*
+	(bitwise-and *pending-interrupts*
+		     (bitwise-not (interrupt-bit interrupt))))
+  (check-for-enabled-interrupt!))
+
+; Install a new set of enabled interrupts.  As usual we have to recheck for
+; enabled interrupts.
+
+(define (set-enabled-interrupts! enabled)
+  (set! *enabled-interrupts* enabled)
+  (check-for-enabled-interrupt!))
+
+; Disable all interrupts.
+
+(define (disable-interrupts!)
+  (set! s48-*pending-interrupt?* #f)
+  (set! *enabled-interrupts* 0))
+
+; Enable all interrupts.
+
+(define (enable-interrupts!)
+  (set-enabled-interrupts! -1))
+
+; Whenever *PENDING-INTERRUPTS* or *ENABLED-INTERRUPTS* changes we have to
+; set S48-*PENDING-INTERRUPT?* to the correct value.
+
+(define (check-for-enabled-interrupt!)
+  (if (= 0 (bitwise-and *pending-interrupts* *enabled-interrupts*))
+      (begin
+	(set! s48-*pending-interrupt?* #f)  ; Done first to avoid a race condition.
+	(if s48-*pending-events?*
+	    (set! s48-*pending-interrupt?* #t)))
+      (set! s48-*pending-interrupt?* #t)))
+
+; We don't need to mess with S48-*PENDING-INTERRUPT?* because all interrupts
+; are about to be disabled.
+
+(define (get-highest-priority-interrupt!)
+  (let ((n (bitwise-and *pending-interrupts* *enabled-interrupts*)))
+    (let loop ((i 0) (m 1))
+      (cond ((= 0 (bitwise-and n m))
+	     (loop (+ i 1) (* m 2)))
+	    (else
+	     (set! *pending-interrupts*
+		   (bitwise-and *pending-interrupts* (bitwise-not m)))
+	     i)))))
+
+; Process any pending OS events.  PROCESS-EVENT returns a mask of any interrupts
+; that have just occured.
+
+(define (check-events)
+  (receive (type channel status)
+      (get-next-event)
+    (set! *pending-interrupts*
+	  (bitwise-ior (process-event type channel status)
+		       *pending-interrupts*))
+    (if (eq? type (enum events no-event))
+	(begin
+	  (check-for-enabled-interrupt!)
+	  (pending-interrupt?))
+	(check-events))))
+
+; Do whatever processing the event requires.
+
+(define (process-event event channel status)
+  (cond ((eq? event (enum events alarm-event))
+	 ;; Save the interrupted template for use by profilers.
+	 (if (false? *interrupted-template*)
+	     (set! *interrupted-template* *template*))
+	 (interrupt-bit (enum interrupt alarm)))
+	((eq? event (enum events keyboard-interrupt-event))
+	 (interrupt-bit (enum interrupt keyboard)))
+	((eq? event (enum events io-completion-event))
+	 (enqueue-channel! channel status)
+	 (interrupt-bit (enum interrupt i/o-completion)))
+	((eq? event (enum events os-signal-event))
+	 (interrupt-bit (enum interrupt os-signal)))
+	((eq? event (enum events no-event))
+	 0)
+	((eq? event (enum events error-event))
+	 (error-message "OS error while getting event")
+	 (error-message (error-string status))
+	 0)
+	(else
+	 (error-message "unknown type of event")
+	 0)))
+
+; Return a bitmask for INTERRUPT.
+
+(define (interrupt-bit interrupt)
+  (shift-left 1 interrupt))
+
+
diff --git a/scheme/vm/load-vm.scm b/scheme/vm/load-vm.scm
new file mode 100644
index 0000000..f8252c2
--- /dev/null
+++ b/scheme/vm/load-vm.scm
@@ -0,0 +1,111 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; To load the VM into Scheme 48:
+;   ,exec ,load load-vm.scm
+;
+; You must have already loaded Pre-Scheme.
+;
+; Then, for example,
+;  (start-vm "=scheme48/../build/initial.image" 4000000 20000 '#())
+; in the user package will start up the VM with the initial image.
+; Be patient.  It will take a while.  Running the initial image as
+; above on a SGI Indy (100 mhz R4000) it took over 70 minutes to
+; get the - prompt.  scheme48.image starts up faster as it does little
+; in the way of initialization.  See below for a way to build a small
+; image that will start up quickly.
+;
+; You will need to have a large heap to start with. -h 12000000 works
+; for loading the initial image in version 0.35, smaller heaps may also
+; work.
+;
+; To send input to the VM, do the following:
+;
+;  Breakpoint: Waiting
+;  1> ,in interpreter (set! s48-*pending-events?* #t)
+;  1> ,proceed
+;  (+ 2 3)                             ; this will be read by the loaded VM
+;  Call to (schedule-interrupt 200)    ; output noise
+;  Call to (schedule-interrupt 200)
+;  Call to (schedule-interrupt 200)
+;  5                                   ; the answer
+;  > Call to (schedule-interrupt 200)  ; prompt by the loaded S48
+;
+;  Breakpoint: Waiting
+;  1>                                  ; prompt by the base S48
+;
+; There can't be a pause between the `,proceed 0' and the input for
+; the loaded VM.  This is easy to accomplish running under Emacs.
+; If there is a pause you will hit the breakpoint again and the
+; `(+ 2 3)' or whatever will be read by the base system.
+;
+; It is easier to debug changes to the VM using images smaller than
+; the usual build/initial.image and scheme48.image.  What I usually
+; do is modify scheme/debug/tiny.scm so that it runs the code I want
+; to test and then build scheme/debug/tiny.image.  The version that
+; comes with the system prints `Hello' and the first command argument,
+; if any, then reads a line from standard input and prints it to
+; standard output.  The image file is less than 12k bytes in size so
+; it starts up much faster than the larger images.  Here is a transcript:
+;
+;    % make scheme/debug/tiny.image
+;    (echo ',batch' && echo ',bench on'; \
+;    echo \(load-configuration \"scheme/debug/tiny-packages.scm\"\); \
+;    echo \(link-simple-system \'\(scheme/debug tiny\) \'start tiny-system\)) \
+;    | ./scheme48vm -h 5000000 -i build/linker.image
+;    Welcome to Scheme 48 0.45 (suspended image).
+;    Copyright (c) 1993, 1994 by Richard Kelsey and Jonathan Rees.
+;    Copyright (c) 1996 by NEC Research Institute, Inc.
+;    Please report bugs to scheme-48-bugs@martigny.ai.mit.edu.
+;    Type ,? (comma question-mark) for help.
+;    > Will exit on errors
+;    Will compile some calls in line
+;    scheme/debug/tiny-packages.scm 
+;    [tiny-system
+;    scheme/debug/tiny.scm ]
+;    Writing scheme/debug/tiny.debug
+;    
+;    % ./scheme48vm -i scheme/debug/tiny.image -a the-argument
+;    Correcting byte order of resumed image.
+;    Hello the-argument
+;    now I type a line to be echoed
+;    now I type a line to be echoed
+;    % 
+;
+; When modifying scheme/debug/tiny.scm you have to keep in mind that
+; you can only use the basic system: only the standard special forms
+; (no LET, for example) and only the primitives implemented by the
+; VM (no MAP, etc.).  
+
+(config)
+(load "interfaces.scm")
+(load "s48-package-defs.scm")
+(load "package-defs.scm")
+(load-package 'destructuring)  ; used in FOR-SYNTAX clause
+(load-package 'bigbit)
+(load-package 'vm)
+
+(user)
+(open 'ps-memory)
+(open 'vm)
+(open 'heap-init)
+(open 'images)
+(open 'memory-debug)
+
+(run '
+(define (start-vm image-file heap-size stack-size start-args)
+  (reinitialize-memory)
+  (let ((needed-space (+ (quotient (s48-check-image-header image-file) 4))))
+    (cond ((< heap-size (* 16 needed-space))
+           (display "Heap too small, want at least ")
+           (display (* 16 needed-space))
+           (newline))
+          (else
+           (let ((heap (allocate-memory heap-size))
+                 (stack (allocate-memory stack-size)))
+	     (s48-initialize-heap heap (quotient heap-size 4))
+	     (s48-read-image)
+	     (s48-initialize-vm stack (quotient stack-size 4))
+	     (s48-call-startup-procedure start-args
+					 (vector-length start-args)))))))
+)
diff --git a/scheme/vm/macro-package-defs.scm b/scheme/vm/macro-package-defs.scm
new file mode 100644
index 0000000..7c6a333
--- /dev/null
+++ b/scheme/vm/macro-package-defs.scm
@@ -0,0 +1,8 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; VM-ARCHITECTURE is used in a FOR-SYNTAX clause in the VM package definitions.
+
+(define-structures ((vm-architecture (export stob-data)))
+  (open scheme enumerated)
+  (files arch))
diff --git a/scheme/vm/memory.scm b/scheme/vm/memory.scm
new file mode 100644
index 0000000..066aeb9
--- /dev/null
+++ b/scheme/vm/memory.scm
@@ -0,0 +1,87 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; This is file memory.scm.
+
+; Fundamental parameters
+
+(define bits-per-byte 8)
+(define bytes-per-cell 4)
+(define bits-per-cell (* bits-per-byte bytes-per-cell))
+
+(define (bytes->cells bytes)
+  ; using shift instead of quotient for speed
+  ; (quotient (+ bytes (- bytes-per-cell 1)) bytes-per-cell)
+  (arithmetic-shift-right (+ bytes (- bytes-per-cell 1))
+			  2))  ; log(bytes-per-cell)
+
+(define (cells->bytes cells)
+  (* cells bytes-per-cell))
+
+; Addresses
+;
+;  An "addressing unit" is the smallest quantum of storage addressed by
+;  an address on a particular machine.  On a DEC-20, 3600, or other
+;  word-addressed architecture there is one addressing unit per cell.  On
+;  the VAX or 68000, though, the addressing unit is the byte, of which there
+;  are 4 to a cell.
+;
+;  Note: by a "byte" is meant enough bits to store either a character or
+;  a bytecode.  That probably means either 7, 8, or 9 bits.
+;
+;  If the addressing unit is smaller than a cell each address will have some
+;  number of "unused bits" at its low end.  On a byte-addressable machine with
+;  32 bit addresses, there are two.
+
+(define unused-field-width 2)
+
+(define addressing-units-per-cell 4)
+
+(define (cells->a-units cells)
+  (adjoin-bits cells 0 unused-field-width))
+
+(define (a-units->cells cells)
+  (high-bits cells unused-field-width))
+
+(define (bytes->a-units byte-count)
+  (cells->a-units (bytes->cells byte-count)))
+
+(define (address1+ x)
+  (address+ x addressing-units-per-cell))
+
+(define (address2+ x)
+  (address1+ (address1+ x)))
+
+; Memory access
+
+(define *memory*)
+(define *memory-begin* 0)
+(define *memory-end* 0)
+
+(define (memory-begin)
+  *memory-begin*)
+
+; Size of memory in cells.
+(define (memory-size)
+  (a-units->cells (address-difference *memory-end* *memory-begin*)))
+
+(define (create-memory size initial-value)   ;size in cells
+  (let ((size (cells->a-units size)))
+    (cond ((not (= size (address-difference *memory-end* *memory-begin*)))
+	   (if (not (= *memory-end* 0))
+	       (deallocate-memory *memory*))
+           (set! *memory* (allocate-memory size))
+	   (if (= -1 *memory*)
+	       (error "out of memory, unable to continue"))
+	   (set! *memory-begin* *memory*)
+           (set! *memory-end* (+ *memory* size))))))
+
+(define fetch word-ref)
+(define fetch-byte unsigned-byte-ref)
+(define store! word-set!)
+(define store-byte! unsigned-byte-set!)
+
+(define fetch-string char-pointer->string)
+(define fetch-nul-terminated-string char-pointer->nul-terminated-string)
+
diff --git a/scheme/vm/no-gc-package-defs.scm b/scheme/vm/no-gc-package-defs.scm
new file mode 100644
index 0000000..937c1ea
--- /dev/null
+++ b/scheme/vm/no-gc-package-defs.scm
@@ -0,0 +1,84 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; These are used to compile the VM separately from the GC.  It has new
+; definitions of the heap and GC structures with all of the values defined
+; as externals.
+
+(define-structure allocation allocation-interface
+  (open prescheme)
+  (begin
+    (define s48-available?
+      (external "AVAILABLEp" (=> (integer) boolean))) ; macro
+    (define (s48-preallocate-space size) 0)
+    (define (s48-allocate-space type size key)
+      (= key 0)  ; make type checker happy about KEY
+      ((external "ALLOCATE_SPACE" (=> (integer integer) address)) type size))
+    (define s48-write-barrier
+      (external "S48_WRITE_BARRIER" (=> (integer address integer) null)))))
+
+(define-structure heap heap-interface
+  (open prescheme)
+  (begin
+    (define s48-available
+      (external "s48_available" (=> () integer)))
+    (define s48-heap-size
+      (external "s48_heap_size" (=> () integer)))
+    (define s48-find-all
+      (external "s48_find_all" (=> (integer) integer)))
+    (define s48-find-all-records
+      (external "s48_find_all_records" (=> (integer) integer)))
+    (define s48-*hp*
+      (external "s48_ShpS" integer))
+    (define s48-*limit*
+      (external "s48_SlimitS" integer))))
+
+(define-structure gc gc-interface
+  (open prescheme)
+  (begin
+    (define s48-begin-collection
+      (external "s48_begin_collection" (=> () null)))
+    (define s48-trace-value
+      (external "s48_trace_value" (=> (integer) integer)))
+    (define s48-trace-locations!
+      (external "s48_trace_locationsB" (=> (address address) null)))
+    (define s48-trace-stob-contents!
+      (external "s48_trace_stob_contentsB" (=> (integer) null)))
+    (define s48-extant?
+      (external "s48_extantP" (=> (integer) boolean)))
+    (define s48-do-gc
+      (external "s48_do_gc" (=> () null)))
+    (define s48-end-collection
+      (external "s48_end_collection" (=> () null)))
+    (define s48-gc-count
+      (external "s48_gc_count" (=> () integer)))))
+
+(define-structure images images-interface
+  (open prescheme)
+  (begin
+    (define s48-image-writing-okay?
+      (external "s48_image_writing_okayP" (=> () boolean)))
+    (define s48-write-image
+      (external "s48_write_image" (=> (integer output-port) integer)))
+    (define s48-check-image-header
+      (external "s48_check_image_header" (=> ((^ char)) integer)))
+    (define s48-read-image
+      (external "s48_read_image" (=> (integer) integer)))
+
+    (define s48-startup-procedure
+      (external "s48_startup_procedure" (=> () integer)))
+    (define s48-initial-symbols
+      (external "s48_initial_symbols" (=> () integer)))
+    (define s48-initial-imported-bindings
+      (external "s48_initial_imported_bindings" (=> () integer)))
+    (define s48-initial-exported-bindings
+      (external "s48_initial_exported_bindings" (=> () integer)))
+    (define s48-resumer-records
+      (external "s48_resumer_records" (=> () integer)))
+    (define s48-undumpable-records
+      (external "s48_undumpable_records" (=> () integer integer)))
+
+    (define s48-initialization-complete!
+      (external "s48_initialization_completeB" (=> () null)))
+    (define s48-initializing-gc-root
+      (external "s48_initializing_gc_root" (=> () null)))))
+
diff --git a/scheme/vm/package-defs.scm b/scheme/vm/package-defs.scm
new file mode 100644
index 0000000..d2fb635
--- /dev/null
+++ b/scheme/vm/package-defs.scm
@@ -0,0 +1,217 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Additional packages are in s48-package-defs.scm (for loading into
+; Scheme 48) and ps-package-defs.scm (for compiling as Pre-Scheme).
+
+; The VM
+
+(define-structure vm vm-interface
+  (open prescheme ps-receive vm-architecture vm-utilities
+	data struct
+	interpreter interpreter-internal
+	stack gc interpreter-gc
+	vmio
+	arithmetic-opcodes
+	external-opcodes
+	symbols
+	io-opcodes
+	images)
+  (files resume)
+  (begin
+    (define (s48-disable-interrupts!)
+      (disable-interrupts!))
+
+    (define (s48-enable-interrupts!)
+      (enable-interrupts!))
+
+    ; used for raising exceptions in external code
+    (define (s48-push x)
+      (push x))
+    
+    (define (s48-stack-ref i)
+      (stack-ref i))
+    
+    (define (s48-stack-set! x v)
+      (stack-set! x v))))
+
+;----------------
+; The interpreter
+
+(define-structure vm-architecture vm-architecture-interface
+  (open prescheme)
+  (files arch))
+
+(define-structures ((interpreter interpreter-interface)
+		    (interpreter-internal interpreter-internal-interface))
+  (open prescheme ps-receive vm-utilities vm-architecture enum-case
+	events
+	memory data stob struct allocation vmio
+	interpreter-gc gc
+	heap stack environment external)
+  (for-syntax (open scheme destructuring signals))
+  (files interp call define-primitive prim interrupt)
+  ;(optimize auto-integrate)
+  )
+
+; Assorted additional opcodes
+
+(define-structure arithmetic-opcodes (export)
+  (open prescheme interpreter-internal 
+	data struct
+	fixnum-arithmetic)
+  (files fixnum-op))
+
+(define-structure external-opcodes external-opcodes-interface
+  (open prescheme vm-architecture ps-receive
+	interpreter-internal stack
+	memory data struct
+	gc interpreter-gc
+	string-tables
+	external)
+  (files external-call))
+
+(define-structure symbols (export s48-copy-symbol-table
+				  install-symbols!+gc)
+  (open prescheme vm-utilities vm-architecture
+	interpreter-internal
+	memory heap data struct string-tables
+	gc interpreter-gc)
+  (files symbol))
+
+(define-structure io-opcodes (export)
+  (open prescheme vm-utilities vm-architecture ps-receive
+	interpreter-internal
+	channel-io vmio
+	memory data struct
+	images interpreter-gc
+	symbols external-opcodes
+	stack			;pop
+	stob)			;immutable
+  (files prim-io))
+
+; The stack and lexical evironments
+
+(define-structures ((stack stack-interface)
+		    (initialize-stack (export initialize-stack+gc))
+		    (environment environment-interface))
+  (open prescheme vm-utilities ps-receive ps-memory
+	vm-architecture memory data stob struct
+	allocation
+	interpreter-gc)
+  ;(optimize auto-integrate)
+  (files stack env))
+
+;----------------
+; Data structures
+
+(define-structure memory memory-interface
+  (open prescheme ps-memory vm-utilities)
+  ;(optimize auto-integrate)
+  (files memory))
+
+(define-structure data data-interface
+  (open prescheme vm-utilities
+	system-spec vm-architecture memory)
+  ;(optimize auto-integrate)
+  (files data))
+
+(define-structure stob stob-interface
+  (open prescheme ps-receive vm-utilities vm-architecture
+	memory data allocation)
+  ;(optimize auto-integrate)
+  (files stob))
+
+(define-structure struct struct-interface
+  (open prescheme vm-utilities
+	vm-architecture memory data stob allocation)
+  (for-syntax (open scheme vm-architecture destructuring))
+  ;(optimize auto-integrate)
+  (files defdata struct))
+
+;----------------
+; Memory management
+
+(define-structures ((allocation allocation-interface)
+		    (heap heap-interface)
+		    (heap-gc/image heap-gc/image-interface)
+		    (heap-init heap-init-interface))
+  (open prescheme ps-receive vm-utilities vm-architecture memory data)
+  (files heap))
+
+(define-structures ((gc gc-interface)
+		    (image-gc (export begin-writing-image
+				      abort-collection
+				      s48-undumpable-records)))
+  (open prescheme ps-receive vm-utilities vm-architecture
+	memory data struct
+	heap heap-gc/image allocation)
+  (files gc))
+
+(define-structure images images-interface
+  (open prescheme vm-utilities ps-receive vm-architecture
+	memory data
+	heap heap-gc/image
+	gc image-gc
+	vmio			;mark-traced-channels-closed!
+	symbols			;copy-symbol-table
+	external-opcodes)	;exported-bindings cleaned-imported-bindings
+  (files image))
+
+;----------------
+; GC and allocation utilities for the interpreter.
+
+(define-structure interpreter-gc interpreter-gc-interface
+  (open prescheme ps-receive vm-utilities
+	data
+	gc
+	allocation)
+  (files interp-gc))
+
+; Registering and tracing external GC roots.
+
+(define-structure external-gc-roots external-gc-roots-interface
+  (open prescheme ps-memory
+	memory stob
+	gc interpreter-gc)
+  (files gc-root))
+
+;----------------
+; Low level stuff.
+
+(define-structure vmio vmio-interface
+  (open prescheme ps-receive channel-io vm-utilities
+	data stob struct allocation memory
+	interpreter-gc		;ensure-space
+	vm-architecture)	;port-status
+  ;(optimize auto-integrate)
+  (files vmio))
+
+(define-structure fixnum-arithmetic fixnum-arithmetic-interface
+  (open prescheme vm-utilities data
+	memory)  ; bits-per-cell
+  ;(optimize auto-integrate)
+  (files arith))
+
+(define-structure string-tables string-table-interface
+  (open prescheme vm-utilities
+	data struct
+	interpreter-gc gc)
+  (files vm-tables))
+
+(define-structure enum-case (export (enum-case :syntax))
+  (open prescheme)
+  (begin
+    (define-syntax enum-case
+      (syntax-rules (else)
+	((enum-case enumeration (x ...) clause ...)
+	 (let ((temp (x ...)))
+	   (enum-case enumeration temp clause ...)))
+	((enum-case enumeration value ((name ...) body ...) rest ...)
+	 (if (or (= value (enum enumeration name)) ...)
+	     (begin body ...)
+	     (enum-case enumeration value rest ...)))
+	((enum-case enumeration value (else body ...))
+	 (begin body ...))
+	((enum-case enumeration value)
+	 (unspecific))))))
+
diff --git a/scheme/vm/prim-arith.scm b/scheme/vm/prim-arith.scm
new file mode 100644
index 0000000..85dff3d
--- /dev/null
+++ b/scheme/vm/prim-arith.scm
@@ -0,0 +1,2 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
diff --git a/scheme/vm/prim-io.scm b/scheme/vm/prim-io.scm
new file mode 100644
index 0000000..d3c4c8b
--- /dev/null
+++ b/scheme/vm/prim-io.scm
@@ -0,0 +1,427 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; I/O primitives
+
+; See doc/io.txt for a description of Scheme 48's I/O system.
+
+; Argument specs
+
+(define open-input-port->
+  (input-type (lambda (x)
+		(and (port? x)
+		     (port-has-status? x (enum port-status-options
+					       open-for-input))))
+	      no-coercion))
+
+(define open-output-port->
+  (input-type (lambda (x)
+		(and (port? x)
+		     (port-has-status? x (enum port-status-options
+					       open-for-output))))
+	      no-coercion))
+
+(define channel->     (input-type channel?        no-coercion))
+
+(define (port-has-status? port status)
+  (not (= 0 (bitwise-and (extract-fixnum (port-status port))
+			 (shift-left 1 status)))))
+
+; Check SPEC type and then call OPEN-CHANNEL.
+
+(define-consing-primitive open-channel (any-> fixnum->)
+  (lambda (ignore) (+ channel-size error-string-size))
+  (lambda (spec mode key)
+    (let* ((lose (lambda (reason)
+		   (raise-exception* reason 0 spec (enter-fixnum mode))))
+	   (os-lose (lambda (status)
+		      (raise-exception os-error 0
+				       spec
+				       (enter-fixnum mode)
+				       (get-error-string status key))))
+	   (win (lambda (index)
+		  (receive (channel reason)
+		      (make-registered-channel mode spec index key)
+		    (cond ((false? channel)
+			   (if (vm-string? spec)
+			       (close-channel-index! index spec mode))
+			   (lose reason))
+			  (else
+			   (goto return channel)))))))
+      (cond ((not (open-channel-status? mode))
+	     (lose (enum exception wrong-type-argument)))
+	    ((fixnum? spec)
+	     (if (<= 0 (extract-fixnum spec))
+		 (win (extract-fixnum spec))
+		 (lose (enum exception wrong-type-argument))))
+	    ((vm-string? spec)
+	     (receive (channel status)
+		 (if (or (= mode (enum channel-status-option input))
+			 (= mode (enum channel-status-option special-input)))
+		     (open-input-file-channel (extract-string spec))
+		     (open-output-file-channel (extract-string spec)))
+	       (cond ((eq? status (enum errors no-errors))
+		      (win channel))
+		     ((eq? status (enum errors file-not-found))
+		      (lose (enum exception cannot-open-channel)))
+		     (else
+		      (os-lose status)))))
+	    (else
+	     (lose (enum exception wrong-type-argument)))))))
+
+(define (open-channel-status? mode)
+  (or (= mode (enum channel-status-option input))
+      (= mode (enum channel-status-option output))
+      (= mode (enum channel-status-option special-input))
+      (= mode (enum channel-status-option special-output))))
+
+(define-consing-primitive close-channel (channel->)
+  (lambda (ignore) error-string-size)
+  (lambda (channel key)
+    (if (open? channel)
+	(let ((status (close-channel! channel)))
+	  (if (error? status)
+	      (raise-exception os-error 0 channel (get-error-string status key))
+	      (goto no-result)))
+	(raise-exception wrong-type-argument 0 channel))))
+
+(define (channel-read-or-write read? proc)
+  (lambda (thing start count wait? channel key)
+    (let ((lose (lambda (reason)
+		  (if read?
+		      (raise-exception*
+		         reason 0
+			 thing
+			 (enter-fixnum start)
+			 (enter-fixnum count)
+			 (enter-boolean wait?)
+			 channel)
+		      (raise-exception*
+		         reason 0
+			 thing
+			 (enter-fixnum start)
+			 (enter-fixnum count)
+			 channel))))
+	  (os-lose (lambda (status)
+		     (if read?
+			 (raise-exception os-error 0
+					  thing
+					  (enter-fixnum start)
+					  (enter-fixnum count)
+					  (enter-boolean wait?)
+					  channel
+					  (get-error-string status key))
+			 (raise-exception os-error 0
+					  thing
+					  (enter-fixnum start)
+					  (enter-fixnum count)
+					  channel
+					  (get-error-string status key))))))
+      (if (and (if read?
+		   (and (input-channel? channel)
+			(not (immutable? thing)))
+		   (output-channel? channel))
+	       (or (vm-string? thing)
+		   (code-vector? thing)))
+	  (let ((length (if (vm-string? thing)
+			    (vm-string-length thing)
+			    (code-vector-length thing)))
+		(addr (address+ (address-after-header thing) start)))
+	    (if (< length (+ start count))
+		(lose (enum exception index-out-of-range))
+		(proc channel addr count wait? lose os-lose)))
+	  (lose (enum exception wrong-type-argument))))))
+
+; FETCH-STRING here avoids a type warning in the C code, but is not really
+; the right thing.
+
+(define (do-channel-read channel start count wait? lose os-lose)
+  (receive (got eof? pending? status)
+      (channel-read-block (extract-channel channel) start count wait?)
+    (cond ((error? status)
+	   (os-lose status))
+	  (eof?
+	   (goto return eof-object))
+	  (pending?
+	   (set-channel-os-status! channel true)  ; note that we're waiting
+	   (disable-interrupts!)  ; keep the result pending for a moment
+	   (lose (enum exception pending-channel-i/o)))
+	  (else
+	   (goto return-fixnum got)))))
+
+; WAIT? is ignored when writing.
+
+(define (do-channel-write channel start count wait? lose os-lose)
+  (receive (got pending? status)
+      (channel-write-block (extract-channel channel) start count)
+    (cond ((error? status)
+	   (os-lose status))
+	  (pending?
+	   (set-channel-os-status! channel true)  ; note that we're waiting
+	   (disable-interrupts!)  ; keep the result pending for a moment
+	   (lose (enum exception pending-channel-i/o)))
+	  (else
+	   (goto return-fixnum got)))))
+
+(define (extract-channel channel)
+  (extract-fixnum (channel-os-index channel)))
+
+(let ((do-it (channel-read-or-write #t do-channel-read)))
+  (define-consing-primitive channel-maybe-read
+    (any-> fixnum-> fixnum-> boolean-> channel->)
+    (lambda (ignore) error-string-size)
+    do-it))
+  
+(let ((do-it (channel-read-or-write #f do-channel-write)))	   
+  (define-consing-primitive channel-maybe-write
+    (any-> fixnum-> fixnum-> channel->)
+    (lambda (ignore) error-string-size)
+    (lambda (buffer start count channel key)
+      (do-it buffer start count #f channel key))))
+
+(define-primitive channel-abort (channel->)
+  (lambda (channel)
+    (goto return (vm-channel-abort channel))))
+
+(define-primitive open-channels-list ()
+  (lambda ()
+    (goto return (open-channels-list))))
+
+; Copying error strings into the heap.
+
+(define max-error-string-length 256)
+
+(define error-string-size (vm-string-size max-error-string-length))
+
+(define (get-error-string status key)
+  (let* ((string (error-string status))
+	 (len (min (string-length string)
+		   max-error-string-length))
+	 (new (vm-make-string len key)))
+    (do ((i 0 (+ i 1)))
+	((= i len))
+      (vm-string-set! new i (string-ref string i)))
+    new))
+
+;----------------------------------------------------------------
+; Port instructions.
+;
+; These are only for speed.  If no port was supplied by the user they have
+; to look up the appropriate port in the current dynamic environments.
+; This is a complete hack, also done for speed.  See rts/current-port.scm
+; for the other end.
+
+(define (read-or-peek-char read?)
+  (lambda ()
+    (let ((port (if (= (code-byte 0) 0)
+		    (val)
+		    (get-current-port
+		      (enter-fixnum
+		        (enum current-port-marker current-input-port))))))
+      (if (and (port? port)
+	       (port-has-status? port
+				 (enum port-status-options open-for-input)))
+	  (let ((i (extract-fixnum (port-index port)))
+		(l (extract-fixnum (port-limit port)))
+		(b (port-buffer port)))
+	    (cond ((or (vm-eq? (port-locked? port) true)
+		       (= i l))
+		   (raise-exception buffer-full/empty 1 port))
+		  (else
+		   (if read?
+		       (set-port-index! port (enter-fixnum (+ i 1))))
+		   (goto continue-with-value
+			 (enter-char (ascii->char (code-vector-ref b i)))
+			 1))))
+	  (raise-exception wrong-type-argument 1 port)))))
+
+(let ((do-it (read-or-peek-char #t)))
+  (define-primitive read-char () do-it))
+
+(let ((do-it (read-or-peek-char #f)))
+  (define-primitive peek-char () do-it))
+
+(define-primitive write-char ()
+  (lambda ()
+    (receive (char port)
+	(if (= (code-byte 0) 0)
+	    (values (pop)
+		    (val))
+	    (values (val)
+		    (get-current-port (enter-fixnum
+				       (enum current-port-marker
+					     current-output-port)))))
+      (if (and (vm-char? char)
+	       (port? port)
+	       (port-has-status? port
+				 (enum port-status-options open-for-output)))
+	  (let ((i (extract-fixnum (port-index port)))
+		(b (port-buffer port)))
+	    (cond ((or (vm-eq? (port-locked? port) true)
+		       (= i (code-vector-length b)))
+		   (raise-exception buffer-full/empty 1 char port))
+		  (else
+		   (set-port-index! port (enter-fixnum (+ i 1)))
+		   (code-vector-set! (port-buffer port)
+				     i
+				     (char->ascii (extract-char char)))
+		   (goto continue-with-value
+			 unspecific-value
+			 1))))
+	  (raise-exception wrong-type-argument 1 char port)))))
+	  
+; Do an ASSQ-like walk up the current dynamic environment, looking for
+; MARKER.
+
+(define (get-current-port marker)
+  (let ((thread (current-thread)))
+    (if (and (record? thread)
+	     (< 1 (record-length thread)))
+	(let loop ((env (record-ref thread 1)))
+	  (cond ((not (and (vm-pair? env)
+			   (vm-pair? (vm-car env))))
+		 (if (vm-eq? env null)
+		     (error (if (eq? (extract-fixnum marker)
+				     (enum current-port-marker
+					   current-output-port))
+				"dynamic environment doesn't have current-output-port"
+				"dynamic environment doesn't have current-input-port"))
+		     (error "dynamic environment is not a proper list")))
+		((vm-eq? marker (vm-car (vm-car env)))
+		 (vm-cdr (vm-car env)))
+		(else
+		 (loop (vm-cdr env)))))
+	(error "current thread is not a record"))))
+
+;----------------
+; A poor man's WRITE for use in debugging.
+
+(define-primitive message (any->)
+  (lambda (stuff)
+    (let ((out (current-error-port)))
+      (let loop ((stuff stuff))
+	(if (vm-pair? stuff)
+	    (begin
+	      (message-element (vm-car stuff) out)
+	      (loop (vm-cdr stuff)))))
+      (newline out)))
+  return-unspecific)
+    
+(define (message-element thing out)
+  (cond ((fixnum? thing)
+	 (write-integer (extract-fixnum thing) out))
+	((vm-char? thing)
+	 (write-string "#\\" out)
+	 (write-char (extract-char thing) out))
+	((typed-record? thing)
+	 (write-string "#{" out)
+	 (write-string (extract-string (record-type-name thing)) out)
+	 (write-char #\} out))
+	(else
+	 (write-string (cond ((vm-string? thing)
+			      (extract-string thing))
+			     ((vm-symbol? thing)
+			      (extract-string (vm-symbol->string thing)))
+			     ((vm-boolean? thing)
+			      (if (extract-boolean thing) "#t" "#f"))
+			     ((vm-eq? thing null)
+			      "()")
+			     ((vm-pair? thing)
+			      "(...)")
+			     ((vm-vector? thing)
+			      "#(...)")
+			     ((closure? thing)
+			      "#{procedure}")
+			     (else
+			      "???"))
+		       out))))
+
+(define (typed-record? thing)
+  (and (record? thing)
+       (< 0 (record-length thing))
+       (let ((type (record-ref thing 0)))
+	 (and (record? type)
+	      (< 2 (record-length type))
+	      (vm-symbol? (record-ref type 2))))))
+
+(define (record-type-name record)
+  (vm-symbol->string (record-ref (record-ref record 0) 2)))
+
+(define-primitive copy-bytes! (any-> fixnum-> any-> fixnum-> fixnum->)
+  (lambda (from from-index to to-index count)
+    (cond ((and (or (vm-string? from)
+		    (code-vector? from))
+		(or (vm-string? from)
+		    (code-vector? from))
+		(<= 0 from-index)
+		(<= 0 to-index)
+		(<= 0 count)
+		(<= (+ from-index count)
+		    (if (vm-string? from)
+			(vm-string-length from)
+			(code-vector-length from)))
+		(<= (+ to-index count)
+		    (if (vm-string? to)
+			(vm-string-length to)
+			(code-vector-length to))))
+	   (copy-memory! (address+ (address-after-header from) from-index)
+			 (address+ (address-after-header to) to-index)
+			 count)
+	   (goto no-result))
+	  (else
+	   (raise-exception wrong-type-argument 0
+			    from (enter-fixnum from-index)
+			    to (enter-fixnum to-index)
+			    (enter-fixnum count))))))
+
+;----------------------------------------------------------------
+; RESUME-PROC is called when the image is resumed.
+; This does a garbage collection rooting from RESUME-PROC, writes the heap
+; into a file, and then aborts the garbage collection (which didn't modify
+; any VM registers or the stack).
+
+; Bug: finalizers for things in the image are ignored.
+
+(define-consing-primitive write-image (string-> any-> string->)
+  (lambda (ignore) error-string-size)
+  (lambda (filename resume-proc comment-string key)
+    (let* ((lose (lambda (reason status)
+		   (raise-exception* reason 0
+				     filename resume-proc comment-string
+				     (get-error-string status key))))
+	   (port-lose (lambda (reason status port)
+			(if (error? (close-output-port port))
+			    (error-message "Unable to close image file"))
+			(lose reason status))))
+      (if (not (s48-image-writing-okay?))
+	  (raise-exception unimplemented-instruction 0
+			   filename resume-proc comment-string)
+	  (receive (port status)
+	      (open-output-file (extract-string filename))
+	    (if (error? status)
+		(lose (enum exception cannot-open-channel) status)
+		(let ((status (write-string (extract-string comment-string) port)))
+		  (if (error? status)
+		      (port-lose (enum exception os-error) status port)
+		      (let ((status (s48-write-image resume-proc port)))
+			(if (error? status)
+			    (port-lose (enum exception os-error) status port)
+			    (let ((status (close-output-port port)))
+			      (if (error? status)
+				  (lose (enum exception os-error) status)
+				  (receive (undumpables undumpable-count)
+				      (s48-undumpable-records)
+				    (if (= undumpable-count 0)
+					(goto no-result)
+		     ; ---------------->
+		     (raise-exception unresumable-records-in-image 0
+				      filename
+				      resume-proc
+				      comment-string
+				      undumpables
+				      (enter-fixnum undumpable-count))))))))))))))))
+
+; READ-IMAGE needs to protect some values against GCs (this can't be with
+; READ-IMAGE as that is compiled separately.)
+
+(add-gc-root! s48-initializing-gc-root)
+
diff --git a/scheme/vm/prim.scm b/scheme/vm/prim.scm
new file mode 100644
index 0000000..eafaab0
--- /dev/null
+++ b/scheme/vm/prim.scm
@@ -0,0 +1,528 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Scalar primitives
+
+(define-primitive eq? (any-> any->) vm-eq? return-boolean)
+
+(define-primitive char?       (any->) vm-char? return-boolean)
+(define-primitive char=?      (vm-char-> vm-char->) vm-char=? return-boolean)
+(define-primitive char<?      (vm-char-> vm-char->) vm-char<? return-boolean)
+(define-primitive char->ascii (char->) char->ascii return-fixnum)
+
+(define-primitive ascii->char
+  (fixnum->)
+  (lambda (x)
+    (if (or (> x 255) (< x 0))
+        (raise-exception wrong-type-argument 0 (enter-fixnum x))
+	(goto return (enter-char (ascii->char x))))))
+
+(define-primitive eof-object?
+  (any->)
+  (lambda (x) (vm-eq? x eof-object))
+  return-boolean)
+
+;----------------
+
+(define-primitive stored-object-has-type?
+  (any->)
+  (lambda (x)
+    (goto continue-with-value
+	  (enter-boolean (stob-of-type? x (code-byte 0)))
+	  1)))
+
+(define-primitive stored-object-length
+  (any->)
+  (lambda (stob)
+    (let ((type (code-byte 0)))
+      (if (stob-of-type? stob type)
+	  (goto continue-with-value
+		(enter-fixnum (d-vector-length stob))
+		1)
+	  (raise-exception wrong-type-argument 1 stob (enter-fixnum type))))))
+  
+; Fixed sized objects
+
+(define-primitive stored-object-ref
+  (any->)
+  (lambda (stob)
+    (let ((type (code-byte 0))
+	  (offset (code-byte 1)))
+      (if (stob-of-type? stob type)
+	  (goto continue-with-value
+		(d-vector-ref stob offset)
+		2)
+	  (raise-exception wrong-type-argument 2
+			   stob
+			   (enter-fixnum type)
+			   (enter-fixnum offset))))))
+
+(define-primitive stored-object-set!
+  (any-> any->)
+  (lambda (stob value)
+    (let ((type (code-byte 0))
+	  (offset (code-byte 1)))
+      (cond ((and (stob-of-type? stob type)
+		  (not (immutable? stob)))
+	     (d-vector-set! stob offset value)
+	     (goto continue-with-value
+		   unspecific-value
+		   2))
+	    (else
+	     (raise-exception wrong-type-argument 2
+			      stob
+			      (enter-fixnum type)
+			      (enter-fixnum offset)
+			      value))))))
+
+; Indexed objects
+
+(define-primitive stored-object-indexed-ref (any-> any->)
+  (lambda (stob index)
+    (let ((type (code-byte 0)))
+      (cond ((or (not (fixnum? index))
+	         (not (stob-of-type? stob type)))
+	     (raise-exception wrong-type-argument 1
+			      stob (enter-fixnum type) index))
+	    ((valid-index? (extract-fixnum index) (d-vector-length stob))
+	     (goto continue-with-value
+		   (d-vector-ref stob (extract-fixnum index))
+		   1))
+	    (else
+	     (raise-exception index-out-of-range 1
+			      stob (enter-fixnum type) index))))))
+
+(define-primitive stored-object-indexed-set! (any-> any-> any->)
+  (lambda (stob index value)
+    (let ((type (code-byte 0)))
+      (cond ((or (not (fixnum? index))
+		 (not (stob-of-type? stob type))
+		 (immutable? stob))
+	     (raise-exception wrong-type-argument 1
+			      stob (enter-fixnum type) index value))
+	    ((valid-index? (extract-fixnum index) (d-vector-length stob))
+	     (d-vector-set! stob (extract-fixnum index) value)
+	     (goto continue-with-value unspecific-value 1))
+	    (else
+	     (raise-exception index-out-of-range 1
+			      stob (enter-fixnum type) index value))))))
+
+; Hacko record handlers done for speed.
+
+(define-primitive checked-record-ref
+  (any-> any-> fixnum->)
+  (lambda (record type index)
+    (cond ((not (and (stob-of-type? record (enum stob record))
+		     (vm-eq? type (record-ref record 0))))
+	   (raise-exception wrong-type-argument 0
+			    record type (enter-fixnum index)))
+	  ((valid-index? index (record-length record))
+	   (goto return (record-ref record index)))
+	  (else
+	   (raise-exception index-out-of-range 0
+			    record type (enter-fixnum index))))))
+
+(define-primitive checked-record-set! (any-> any-> fixnum-> any->)
+  (lambda (record type index value)
+    (cond ((not (and (stob-of-type? record (enum stob record))
+		     (vm-eq? type (record-ref record 0))
+		     (not (immutable? record))))
+	   (raise-exception wrong-type-argument 0
+			    record type (enter-fixnum index) value))
+	  ((valid-index? index (record-length record))
+	   (record-set! record index value)
+	   (goto no-result))
+	  (else
+	   (raise-exception index-out-of-range 0
+			    record type (enter-fixnum index) value)))))
+
+; Constructors
+
+(define-primitive make-stored-object ()
+  (lambda ()
+    (let* ((len (code-byte 0))
+	   (key (ensure-space (cells->bytes (+ stob-overhead len))))
+	   (new (make-d-vector (code-byte 1) len key)))
+      (cond ((>= len 1)
+	     (d-vector-init! new (- len 1) *val*)
+	     (do ((i (- len 2) (- i 1)))
+		 ((> 0 i)
+		  (unspecific))  ; for the type checker!
+	       (d-vector-init! new i (pop)))))
+      (goto continue-with-value new 2))))
+
+; This is for the closed compiled versions of VECTOR and RECORD.
+; *stack* = arg0 arg1 ... argN rest-list N+1 total-nargs
+
+(define-primitive closed-make-stored-object ()
+  (lambda ()
+    (let* ((len (extract-fixnum (pop)))
+	   (key (ensure-space (cells->bytes (+ stob-overhead len))))
+	   (new (make-d-vector (code-byte 0) len key))
+	   (stack-nargs (extract-fixnum (pop)))
+	   (rest-list (pop)))
+      (do ((i (- stack-nargs 1) (- i 1)))
+	  ((> 0 i)
+	   (unspecific))  ; for the type checker!
+	(d-vector-init! new i (pop)))
+      (do ((i stack-nargs (+ i 1))
+	   (rest-list rest-list (vm-cdr rest-list)))
+	  ((vm-eq? rest-list null)
+	   (unspecific))  ; for the type checker!
+	(d-vector-init! new i (vm-car rest-list)))
+      (goto continue-with-value new 1))))
+
+(define-primitive make-vector-object (any-> any->)
+  (lambda (len init)
+    (let ((type (code-byte 0)))
+      (if (fixnum? len)
+	  (let* ((len (extract-fixnum len))
+		 (size (vm-vector-size len)))
+	    (if (or (< len 0)
+		    (> size max-stob-size-in-cells))
+		(raise-exception wrong-type-argument 1
+				 (enter-fixnum type) (enter-fixnum len) init)
+		(receive (okay? key init)
+		    (maybe-ensure-space-saving-temp size init)
+		  (if (not okay?)
+		      (raise-exception heap-overflow 1
+				       (enter-fixnum type) (enter-fixnum len)
+				       init)
+		      (let ((v (make-d-vector type len key)))
+			(do ((i (- len 1) (- i 1)))
+			    ((< i 0))
+			  (d-vector-set! v i init))
+			(goto continue-with-value v 1))))))
+	  (raise-exception wrong-type-argument 1
+			   (enter-fixnum type) len init)))))
+
+; Strings and byte vectors
+
+(define-primitive string-length
+  (string->)
+  (lambda (string)
+    (goto return-fixnum (vm-string-length string))))
+
+(define-primitive byte-vector-length
+  (code-vector->)
+  (lambda (byte-vector)
+    (goto return-fixnum (code-vector-length byte-vector))))
+
+(define (make-byte-ref ref length returner)
+  (lambda (vector index)
+    (if (valid-index? index (length vector))
+	(goto returner (ref vector index))
+	(raise-exception index-out-of-range 0 vector (enter-fixnum index)))))
+
+(let ((proc (make-byte-ref vm-string-ref vm-string-length return-char)))
+  (define-primitive string-ref (string-> fixnum->) proc))
+
+(let ((proc (make-byte-ref code-vector-ref code-vector-length return-fixnum)))
+  (define-primitive byte-vector-ref (code-vector-> fixnum->) proc))
+
+(define (make-byte-setter setter length enter-elt)
+  (lambda (vector index char)
+    (cond ((immutable? vector)
+	   (raise-exception wrong-type-argument 0
+			    vector (enter-fixnum index) (enter-elt char)))
+	  ((valid-index? index (length vector))
+	   (setter vector index char)
+	   (goto no-result))
+	  (else
+	   (raise-exception index-out-of-range 0
+			    vector (enter-fixnum index) (enter-elt char))))))
+
+(let ((proc (make-byte-setter vm-string-set! vm-string-length enter-char)))
+  (define-primitive string-set! (string-> fixnum-> char->) proc))
+
+(let ((proc (make-byte-setter code-vector-set! code-vector-length enter-fixnum)))
+  (define-primitive byte-vector-set! (code-vector-> fixnum-> fixnum->) proc))
+
+(define (byte-vector-maker size maker setter enter-elt)
+  (lambda (len init)
+    (let ((size (size len)))
+      (if (or (< len 0)
+	      (> size max-stob-size-in-cells))
+	  (raise-exception wrong-type-argument 0
+			   (enter-fixnum len) (enter-elt init))
+	  (receive (okay? key)
+	      (maybe-ensure-space size)
+	    (if (not okay?)
+		(raise-exception heap-overflow 0
+				 (enter-fixnum len) (enter-elt init))
+		(let ((vector (maker len key)))
+		  (do ((i (- len 1) (- i 1)))
+		      ((< i 0))
+		    (setter vector i init))
+		  (goto return vector))))))))
+
+(let ((proc (byte-vector-maker vm-string-size
+			       vm-make-string
+			       vm-string-set!
+			       enter-char)))
+  (define-primitive make-string (fixnum-> char->) proc))
+  
+(let ((proc (byte-vector-maker code-vector-size
+			       make-code-vector
+			       code-vector-set!
+			       enter-fixnum)))
+  (define-primitive make-byte-vector (fixnum-> fixnum->) proc))
+
+; Locations & mutability
+
+(define-primitive location-defined? (location->)
+  (lambda (loc)
+    (return-boolean (or (not (undefined? (contents loc)))
+			(= (contents loc) unassigned-marker)))))
+
+(define-primitive set-location-defined?! (location-> boolean->)
+  (lambda (loc value)
+    (cond ((not value)
+	   (set-contents! loc unbound-marker))
+	  ((undefined? (contents loc))
+	   (set-contents! loc unassigned-marker))))
+  return-unspecific)
+
+(define-primitive immutable? (any->) immutable? return-boolean)
+
+(define-primitive make-immutable! (any->)
+  (lambda (thing)
+    (make-immutable! thing)
+    (goto return thing)))
+
+;----------------
+; Misc
+
+(define-primitive false ()
+  (lambda ()
+    (goto return false)))
+
+(define-primitive eof-object ()
+  (lambda ()
+    (goto return eof-object)))
+
+(define-primitive trap (any->)
+  (lambda (arg)
+    (raise-exception trap 0 arg)))
+
+(define-primitive find-all (fixnum->)
+  (lambda (type)
+    (let loop ((first? #t))
+      (let ((vector (s48-find-all type)))
+	(cond ((not (false? vector))
+	       (goto return vector))
+	      (first?
+	       (collect)
+	       (loop #f))
+	      (else
+	       (raise-exception heap-overflow 0 (enter-fixnum type))))))))
+
+(define-primitive find-all-records (any->)
+  (lambda (type)
+    (let loop ((first? #t) (type type))
+      (let ((vector (s48-find-all-records type)))   ; only one call site
+	(cond ((not (false? vector))
+	       (goto return vector))
+	      (first?
+	       (loop #f (collect-saving-temp type)))
+	      (else
+	       (raise-exception heap-overflow 0 type)))))))
+
+(define-primitive collect ()
+  (lambda ()
+    (set! *val* unspecific-value)
+    (collect)
+    (goto continue 0)))
+
+(define-consing-primitive add-finalizer! (any-> any->)
+  (lambda (n) (* 2 vm-pair-size))
+  (lambda (stob proc key)
+    (cond ((not (and (stob? stob)
+		     (closure? proc)))
+	   (raise-exception wrong-type-argument 0 stob proc))
+; This would be useful but could get quite expensive
+;	  ((vm-assq stob *finalizer-alist*)
+;	   (raise-exception has-finalizer 0 stob proc))
+	  (else
+	   (set! *finalizer-alist*
+		 (vm-cons (vm-cons stob proc key)
+			  *finalizer-alist*
+			  key))
+	   (goto no-result)))))
+
+(define-primitive memory-status (fixnum-> any->)
+  (lambda (key other)
+    (enum-case memory-status-option key
+      ((pointer-hash)
+       (goto return (descriptor->fixnum other)))
+      ((available)
+       (goto return-fixnum (s48-available)))
+      ((heap-size)
+       (goto return-fixnum (bytes->cells (s48-heap-size))))
+      ((stack-size)
+       (goto return-fixnum (stack-size)))
+      ((gc-count)
+       (goto return-fixnum (s48-gc-count)))
+      ((expand-heap!)
+       (raise-exception unimplemented-instruction 0 (enter-fixnum key) other))
+      (else
+       (raise-exception bad-option 0 (enter-fixnum key) other)))))
+
+(define-primitive time (fixnum-> any->)
+  (lambda (option other)
+    (enum-case time-option option
+      ((cheap-time)
+       (goto return-fixnum (cheap-time)))
+      ((run-time)
+       (receive (seconds mseconds)
+	   (run-time)
+	 (goto return-time-value option seconds mseconds)))
+      ((real-time)
+       (receive (seconds mseconds)
+	   (real-time)
+	 (goto return-time-value option seconds mseconds)))
+      (else
+       (raise-exception bad-option 0 (enter-fixnum option) other)))))
+      
+; The largest number of seconds that can be converted into a fixnum number
+; of milliseconds.
+
+(define maximum-seconds (quotient (- greatest-fixnum-value 1000) 1000))
+
+(define (return-time-value option seconds mseconds)
+  (if (> seconds maximum-seconds)
+      (raise-exception arithmetic-overflow 0
+		       (enter-fixnum option)
+		       (enter-fixnum seconds)
+		       (enter-fixnum mseconds))
+      (goto return-fixnum (+ (* seconds 1000) mseconds))))
+
+(define-primitive schedule-interrupt (fixnum->)
+  (lambda (delta)
+    (clear-interrupt! (enum interrupt alarm))
+    (goto return-fixnum (schedule-interrupt delta))))
+
+; Convert from the user's exponent to the system's.
+
+;(define (adjust-time mantissa exponent)
+;  (let ((system (clock-exponent)))
+;    (cond ((= exponent system)
+;           mantissa)
+;          ((> system exponent)
+;           (quotient mantissa (expt 10 (- system exponent))))
+;          (else
+;           (* mantissa (expt 10 (- exponent system)))))))
+
+(define-enumeration vm-extension-status
+  (okay
+   exception
+   ))
+
+(define s48-*extension-value*)
+
+(define-primitive vm-extension (fixnum-> any->)
+  (lambda (key value)
+    (let ((status (extended-vm key value)))
+      (cond ((vm-eq? status (enum vm-extension-status okay))
+	     (goto return s48-*extension-value*))
+	    ((vm-eq? status (enum vm-extension-status exception))
+	     (raise-exception extension-exception 0 (enter-fixnum key) value))
+	    (else
+	     (raise-exception extension-return-error 0 (enter-fixnum key) value))))))
+
+; This is exported to keep s48-*EXTENSION-VALUE* from being eliminated by the
+; compiler.
+
+(define (s48-set-extension-value! value)
+  (set! s48-*extension-value* value))
+
+; Used to indicate which stack block we are returning to.  Set to FALSE if we are
+; returning from the VM as a whole.
+(define s48-*callback-return-stack-block* false)
+
+(define-primitive return-from-callback (any-> any->)
+  (lambda (stack-block value)
+    (enable-interrupts!)	; Disabled to ensure that we return to the right
+				; stack block.
+    (set! s48-*callback-return-stack-block* stack-block)
+    value))                     ; the interpreter returns this value
+
+(define-primitive current-thread ()
+  (lambda () *current-thread*)
+  return-any)
+
+(define-primitive set-current-thread! (any->)
+  (lambda (state)
+    (set! *current-thread* state))
+  return-unspecific)
+
+(define-primitive session-data ()
+  (lambda () *session-data*)
+  return-any)
+
+(define-primitive set-session-data! (any->)
+  (lambda (state)
+    (set! *session-data* state))
+  return-unspecific)
+
+; Unnecessary primitives
+
+(define-primitive string=? (string-> string->) vm-string=? return-boolean)
+
+; Special primitive called by the reader.
+; Primitive for the sake of speed.  Probably should be flushed.
+
+(define-consing-primitive reverse-list->string (any-> fixnum->) 
+  (lambda (n) (vm-string-size (extract-fixnum n)))
+  (lambda (l n k)
+    (if (not (or (vm-pair? l) (vm-eq? l null)))
+        (raise-exception wrong-type-argument 0 l (enter-fixnum n))
+        (let ((obj (vm-make-string n k)))
+          (do ((l l (vm-cdr l))
+               (i (- n 1) (- i 1)))
+              ((< i 0)
+	       (goto return obj))
+            (vm-string-set! obj i (extract-char (vm-car l))))))))
+
+(define-primitive string-hash (string->) vm-string-hash return-fixnum)
+
+; Messy because we have to detect circular lists (alternatively we
+; could check for interrupts and then pclsr).  ***
+
+(define-primitive assq (any-> any->)
+  (lambda (thing list)
+    (let ((lose (lambda ()
+		  (raise-exception wrong-type-argument 0 thing list))))
+      (let loop ((list list) (slow list) (move-slow? #t))
+	(cond ((vm-eq? list null)
+	       (goto return-boolean #f))
+	      ((not (vm-pair? list))
+	       (lose))
+	      (else
+	       (let ((head (vm-car list)))
+		 (cond ((not (vm-pair? head))
+			(lose))
+		       ((vm-eq? (vm-car head) thing)
+			(goto return head))
+		       (else
+			(let ((list (vm-cdr list)))
+			  (cond ((eq? list slow)
+				 (lose))
+				(move-slow?
+				 (loop list (vm-cdr slow) #f))
+				(else
+				 (loop list slow #t)))))))))))))
+
+; Eventually add make-table, table-ref, table-set! as primitives?
+; No -- write a compiler instead.
+
+; *** Our entry for the obscure comment of the year contest.
+;
+; Pclsring is the term in ITS for the mechanism that makes the operating system
+; appear to be a virtual machine.  The paradigm is that of the BLT instruction
+; on the PDP-10: its arguments are in a set of registers, and if the instruction
+; gets interrupted in the middle, the registers reflect the intermediate state;
+; the PC is set to the BLT instruction itself, and the process can be resumed
+; in the usual way.
+; For more on pclsring see `Pclsring: Keeping Process State Modular' by Alan
+; Bawden (ftp.ai.mit.edu:pub/alan/pclsr.memo).
diff --git a/scheme/vm/ps-channel.scm b/scheme/vm/ps-channel.scm
new file mode 100644
index 0000000..c0eaaa5
--- /dev/null
+++ b/scheme/vm/ps-channel.scm
@@ -0,0 +1,110 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+; This file contains the type declarations for the VM's interface to
+; unbuffered i/o.  Unbuffered ports are called channels in the VM
+; and FD's in the OS.  The external names are unixoid, but the interface
+; itself is intended to be portable.
+
+(define current-input-channel
+  (external "STDIN_FD" (=> () integer)))
+
+(define current-output-channel
+  (external "STDOUT_FD" (=> () integer)))
+
+(define current-error-channel
+  (external "STDERR_FD" (=> () integer)))
+
+; Converting between ports and channels.
+
+(define input-port->channel
+  (external "fileno" (=> (input-port) integer)))
+
+(define output-port->channel
+  (external "fileno" (=> (output-port) integer)))
+
+(define input-channel->port
+  (external "PS_INPUT_FDOPEN" (=> (integer) input-port integer)))
+
+(define output-channel->port
+  (external "PS_OUTPUT_FDOPEN" (=> (integer) output-port integer)))
+
+; Opening and closing channels
+
+(define open-file-channel
+  (external "ps_open_fd" (=> ((^ char) boolean) integer integer)))
+
+(define (open-input-file-channel name)
+  (open-file-channel name #t))
+
+(define (open-output-file-channel name)
+  (open-file-channel name #f))
+
+(define close-channel
+  (external "ps_close_fd" (=> (integer) integer)))
+
+(define close-input-channel close-channel)
+(define close-output-channel close-channel)
+
+; Read and writing blocks of data
+;
+; (channel-read-block channel buffer count wait?)
+;       -> char-count eof? pending? status
+;
+; (channel-write-block channel buffer count)
+;       -> char-count eof? pending? status
+;
+; CHAR-COUNT - the number of characters read/written
+; EOF? - char-count is ignored if this is true
+; PENDING? - true if the operation cannot complete immediately
+; STATUS - from an enumeration defined as part of Pre-Scheme
+;
+; Pending i/o operations produce i/o-completion events when they're done.
+
+(define channel-read-block
+  (external "ps_read_fd"
+	    (=> (integer address integer boolean) integer boolean boolean integer)))
+
+(define channel-write-block
+  (external "ps_write_fd"
+	    (=> (integer address integer) integer boolean integer)))
+
+(define channel-abort
+  (external "ps_abort_fd_op" (=> (integer) integer)))
+
+;----------------------------------------------------------------
+; Asynchronous external events
+
+; The different kinds of events
+
+(define-external-enumeration events
+  (keyboard-interrupt-event     ; user interrupt
+   io-completion-event          ; a pending i/o operation completed
+   alarm-event                  ; scheduled interrupt
+   os-signal-event		; some OS signal of no interest to the VM occured
+   error-event                  ; OS error occurred
+   no-event                     ; no more pending events
+   ))
+
+; Initialize the event system
+
+(define initialize-events
+  (external "interrupt_init" (=> () integer)))
+
+; True if an event is pending
+
+(define pending-event?
+  (external "pending_eventp" (=> () boolean)))
+
+; Returns the next event.  The second return value is the FD for i/o-completion
+; events and the third is the status for i/o-completion and error events.
+; (currently this is always zero for i/o-completions).
+
+(define get-next-event
+  (external "s48_get_next_event" (=> () integer integer integer)))
+
+; Wait for the next event.  The two arguments are maximum time to wait and
+; whether that time is in minutes (#T) or milliseconds (#F).
+
+(define wait-for-event
+  (external "s48_wait_for_event" (=> (integer boolean) unit)))
+
+
diff --git a/scheme/vm/ps-package-defs.scm b/scheme/vm/ps-package-defs.scm
new file mode 100644
index 0000000..1994d2f
--- /dev/null
+++ b/scheme/vm/ps-package-defs.scm
@@ -0,0 +1,42 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+(define-structures ((vm-utilities vm-utilities-interface))
+  (open prescheme)
+  (files vm-utilities)
+  (begin
+    (define-syntax assert
+      (lambda (exp rename compare)
+    	0))
+    ))
+
+(define-structures ((external external-interface))
+  (open prescheme)
+  (begin
+    (define extended-vm
+      (external "s48_extended_vm" (=> (integer integer) integer)))
+    (define external-call
+      (external "s48_external_call" (=> (integer integer integer address)
+					integer)))
+    (define schedule-interrupt 
+      (external "s48_schedule_alarm_interrupt" (=> (integer) integer)))
+    (define cheap-time
+      (external "CHEAP_TIME" (=> () integer)))
+    (define real-time 
+      (external "s48_real_time" (=> () integer integer)))
+    (define run-time 
+      (external "s48_run_time" (=> () integer integer)))))
+   
+(define-structures ((channel-io channel-interface)
+		    (events event-interface))
+  (open prescheme)
+  (files ps-channel))
+
+; The number of usable bits in a small integer.
+
+(define-structures ((system-spec (export useful-bits-per-word)))
+  (open prescheme)
+  (begin
+    (define useful-bits-per-word 32)   ; when compiled
+    ))
+
diff --git a/scheme/vm/resume.scm b/scheme/vm/resume.scm
new file mode 100644
index 0000000..283f7c1
--- /dev/null
+++ b/scheme/vm/resume.scm
@@ -0,0 +1,60 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; This is file resume.scm.
+
+(define (s48-initialize-vm stack-begin stack-size)
+  (install-symbols!+gc (s48-initial-symbols))
+  (install-shared-bindings!+gc (s48-initial-imported-bindings)
+			       (s48-initial-exported-bindings))
+  (initialize-stack+gc stack-begin stack-size)
+  (initialize-interpreter+gc))
+
+;----------------
+; Push the arguments to the initial procedure (a vector of strings passed
+; in from the outside and the three standard channels) and call it.
+
+(define (s48-call-startup-procedure startup-vector startup-vector-length)
+  (clear-registers)
+  (push (enter-startup-argument+gc startup-vector startup-vector-length))
+  (receive (input output error)
+      (initialize-i/o-system+gc)
+    (push input)
+    (push output)
+    (push error)
+    (push (s48-resumer-records))
+    (s48-initialization-complete!)
+    (s48-restart (s48-startup-procedure) 5)))
+  
+(define (enter-startup-argument+gc startup-vector startup-vector-length)
+  (let* ((size (+ (do ((i 0 (+ i 1))
+		       (size 0 (+ size (vm-string-size
+					(string-length
+					 (vector-ref startup-vector i))))))
+		      ((= i startup-vector-length)
+		       size))
+		  (vm-vector-size startup-vector-length)))
+	 (key (ensure-space size))
+	 (vector (vm-make-vector startup-vector-length key)))
+    (natural-for-each (lambda (i)
+			(vm-vector-set! vector
+					i
+					(enter-string
+					 (vector-ref startup-vector i)
+					 key)))
+		      startup-vector-length)
+    vector))
+
+;----------------
+; Restart the interpreter, calling PROC with NARGS arguments already on the
+; stack.
+
+(define (s48-restart proc nargs)
+  (receive (key proc)
+      (ensure-space-saving-temp (code-vector-size 2) proc)
+    (let ((code (make-code-vector 2 key)))
+      (code-vector-set! code 0 (enum op call))
+      (code-vector-set! code 1 nargs)
+      (set-code-pointer! code 0)
+      (set-val! proc)
+      (interpret (code-pointer)))))
diff --git a/scheme/vm/s48-channel.scm b/scheme/vm/s48-channel.scm
new file mode 100644
index 0000000..a61eda9
--- /dev/null
+++ b/scheme/vm/s48-channel.scm
@@ -0,0 +1,152 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; Implementation of OS channels in Scheme.
+;
+; A channel an index into a vector of ports in the underlying Scheme
+; implementation.
+
+; Vector mapping indicies to ports.
+
+(define *channels* '#())
+
+(define (vector-posq vec thing)
+  (let loop ((i 0))
+    (cond ((= i (vector-length vec))
+	   #f)
+	  ((eq? thing (vector-ref vec i))
+	   i)
+	  (else
+	   (loop (+ i 1))))))
+
+(define (channel->port channel)
+  (vector-ref *channels* channel))
+
+(define input-channel->port channel->port)
+(define output-channel->port channel->port)
+
+(define (port->channel port)
+  (or (vector-posq *channels* port)
+      (make-channel port)))
+
+(define input-port->channel port->channel)
+(define output-port->channel port->channel)
+
+; Add PORT to the vector of channels, reusing a slot if possible.
+
+(define (make-channel port)
+  (let ((channel (or (vector-posq *channels* #f)
+		     (let ((channel (vector-length *channels*)))
+		       (set! *channels* (list->vector
+					 (append (vector->list *channels*)
+						 (list #f #f #f #f))))
+		       channel))))
+    (vector-set! *channels* channel port)
+    channel))
+
+; The default ports
+
+(define (current-input-channel)
+  (port->channel (current-input-port)))
+
+(define (current-output-channel)
+  (port->channel (current-output-port)))
+
+(define (current-error-channel)
+  (port->channel ((structure-ref i/o current-error-port))))
+
+; These just open or close the appropriate port and coerce it to a channel.
+
+(define (open-input-file-channel filename)
+  (receive (port status)
+      ((structure-ref prescheme open-input-file) filename)
+    (if (eq? status (enum (structure-ref prescheme errors) no-errors))
+	(values (port->channel port) status)
+	(values #f status))))
+
+(define (open-output-file-channel filename)
+  (receive (port status)
+      ((structure-ref prescheme open-output-file) filename)
+    (if (eq? status (enum (structure-ref prescheme errors) no-errors))
+	(values (port->channel port) status)
+	(values #f status))))
+
+(define (close-input-channel channel)
+  ((structure-ref prescheme close-input-port) (channel->port channel)))
+
+(define (close-output-channel channel)
+  ((structure-ref prescheme close-output-port) (channel->port channel)))
+
+;----------------
+; Non-blocking I/O (implemented using CHAR-READY?)
+;
+; We keep a list of channels for which the user is waiting.  These will
+; all be input channels as CHAR-READY? only works on input ports.
+
+(define *pending-channels* '())
+
+(define (channel-read-block channel start count wait?)
+  (cond ((char-ready? (channel->port channel))
+	 (receive (count eof? status)
+	     (read-block (channel->port channel) start count)
+	   (values count eof? #f status)))
+	(wait?
+	 (set! *pending-channels* (cons channel *pending-channels*))
+	 (values 0 #f #t (enum (structure-ref prescheme errors) no-errors)))
+	(else
+	 (values 0 #f #f (enum (structure-ref prescheme errors) no-errors)))))
+
+(define (channel-write-block channel start count)
+  (values count #f (write-block (channel->port channel) start count)))
+
+(define (channel-abort channel)
+  (set! *pending-channels* (delq channel *pending-channels*))
+  0)
+
+;----------------
+; Events
+;
+; A keyboard interrupt can be generated by setting the following to #t.
+
+(define *pending-keyboard-interrupt?* #f)
+
+(define (initialize-events)
+  (set! *channels* (make-vector 10 #f))
+  (set! *pending-channels* '())
+  (set! *pending-keyboard-interrupt?* #f))
+
+(define (pending-event?)
+  (or *pending-keyboard-interrupt?*
+      (any? (lambda (channel)
+	      (char-ready? (channel->port channel)))
+	    *pending-channels*)))
+
+; The event enumeration is copied from the C version of this code.
+
+(define-enumeration events
+  (keyboard-interrupt-event
+   io-completion-event
+   alarm-event
+   os-signal-event
+   error-event
+   no-event
+   ))
+
+(define (get-next-event)
+  (cond (*pending-keyboard-interrupt?*
+	 (set! *pending-keyboard-interrupt?* #f)
+	 (values (enum events keyboard-interrupt-event) #f #f))
+	((any (lambda (channel)
+		(char-ready? (channel->port channel)))
+	      *pending-channels*)
+	 => (lambda (channel)
+	      (set! *pending-channels* (delq channel *pending-channels*))
+	      (values (enum events io-completion-event)
+		      channel
+		      0)))
+	(else
+	 (values (enum events no-event) #f #f))))
+
+(define (wait-for-event max-wait minutes?)
+  (breakpoint "Waiting"))
+
+
diff --git a/scheme/vm/s48-package-defs.scm b/scheme/vm/s48-package-defs.scm
new file mode 100644
index 0000000..5834728
--- /dev/null
+++ b/scheme/vm/s48-package-defs.scm
@@ -0,0 +1,35 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+(define-structures ((vm-utilities vm-utilities-interface))
+  (open prescheme)
+  (files vm-utilities)
+  (begin
+;    (define-syntax assert
+;      (lambda (exp rename compare)
+;    	0))
+    (define (assert x)
+      (if (not x)
+    	  (error "assertion failed")))
+    ))
+
+(define-structures ((external external-interface))
+  (open scheme)
+  (for-syntax (open scheme signals)) ; for error
+  (files external))
+
+(define-structures ((channel-io channel-interface)
+		    (events event-interface))
+  (open scheme big-scheme ps-memory structure-refs ports)
+  (access prescheme
+	  i/o)         ; current-error-port
+  (files s48-channel))
+
+; The number of usable bits in a small integer.
+
+(define-structures ((system-spec (export useful-bits-per-word)))
+  (open prescheme)
+  (begin
+    (define useful-bits-per-word 30)   ; in Scheme 48
+    ))
+
diff --git a/scheme/vm/stack.scm b/scheme/vm/stack.scm
new file mode 100644
index 0000000..6a735c1
--- /dev/null
+++ b/scheme/vm/stack.scm
@@ -0,0 +1,509 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; The stack grows from higher addresses to lower ones.
+; *STACK-BEGIN* and *STACK-END* delimit the stack portion of memory.
+; *STACK* points to the next unused cell on top of the stack.
+; *STACK-LIMIT* is value against which stack requests are checked.  There is a
+;   buffer area between the limit and the actual end of the stack.  The buffer
+;   is large enough to contain the default procedure stack requirement plus the
+;   space needed to make a call to an exception plus an interrupts plus some
+;   slack for safety's sake.
+
+; These slots are filled with a funny value so that we can detect overruns.
+
+(define stack-warning-limit 30)
+
+; The supposedly unused space at the end of the stack is marked with this
+; value so that we can detect incursions.
+
+(define stack-marker #xf0f0f0f)
+
+; We need at least this amount of space for the stack.
+
+(define stack-slack
+  (+ default-stack-space
+     continuation-stack-size	    ; *bottom-of-stack*
+     (+ continuation-stack-size 13) ; exceptions need at most 14 values
+                                    ; (long pole is external exceptions with
+                                    ; exception + procedure-name + 10 irritants +
+                                    ; saved-exception + stack-block)
+     (+ continuation-stack-size 7)  ; interrupts need at most 7 values
+                                    ; (also from examining the code)
+     (+ stack-warning-limit 2)))    ; safety
+
+; *BOTTOM-OF-STACK* is a continuation that lies a the base of the stack.
+
+(define *stack-begin*)
+(define *stack-end*)
+(define *stack*)
+(define *stack-limit*)
+
+; Current continuation
+(define *cont*)
+
+; For tracking the reason for copying closures and environments (used for
+; debugging and gathering statistics).
+
+(define-enumeration copy
+  (closure
+   overflow
+   preserve))
+
+; At the bottom of the stack is a special continuation that is never removed.
+; When it is invoked it copies the next continuation out of the heap (if there
+; is any such) and invokes that instead.
+
+(define *bottom-of-stack*)
+
+; Initialize the stack and related registers.  All sizes are in descriptors.
+
+(define (initialize-stack+gc start have-size)
+  (let ((required-size (+ available-stack-space stack-slack)))
+    (receive (start size)
+	(if (>= have-size required-size)
+	    (values start have-size)
+	    (let ((stack (allocate-memory (cells->a-units required-size))))
+	      (if (null-address? stack)
+		  (error "out of memory, unable to continue"))
+	      (values stack required-size)))
+      (set! *stack-begin* start)
+      (set! *stack-end* (address+ start (cells->a-units size)))
+      (set! *stack-limit* (address+ *stack-begin* (cells->a-units stack-slack)))
+      (set! *stack* (the-pointer-before *stack-end*))
+      (set! *cont* false)
+      (set! *env* quiescent)
+      (do ((a start (address1+ a)))
+	  ((address= a *stack-end*))
+	(store! a stack-marker))
+      (let ((key (ensure-space (op-template-size 2))))
+	(push-continuation-on-stack
+	  (make-template-containing-ops (enum op get-cont-from-heap)
+					(enum op return)
+					key)
+	  (enter-fixnum 0)
+	  0))
+      (set! *bottom-of-stack* *cont*))))
+
+(define (reset-stack-pointer base-continuation)
+  (set! *stack* (the-pointer-before
+		 (the-pointer-before (address-after-header *bottom-of-stack*))))
+  (set-continuation-cont! *bottom-of-stack* base-continuation)
+  (set! *cont* *bottom-of-stack*))
+
+;----------------
+; Utilities
+
+(define (within-stack? p)
+  (and (stob? p)
+       (>= p (address->integer *stack-begin*))
+       (<= p (address->integer *stack-end*))))
+
+(define (stack-size)
+  (address-difference *stack-end* *stack-begin*))
+
+; The stob-overhead is to get room for one vector that is made.
+(define (current-stack-size)
+  (+ stob-overhead (a-units->cells (address-difference *stack-end* *stack*))))
+
+; Add CELLS cells onto the stack.
+; The stack grows towards negative memory.
+
+(define (add-cells-to-stack! cells)
+  (set! *stack* (address- *stack* (cells->a-units cells))))
+
+(define (the-pointer-before x)
+  (address- x (cells->a-units 1)))
+
+(define (push x)     ; check for overflow is done when continuations are pushed
+  (store! *stack* x)
+  (add-cells-to-stack! 1))
+
+(define (pop)
+  (add-cells-to-stack! -1)
+  (fetch *stack*))
+
+; Use the stack as a vector, with (STACK-REF 0) => current top of stack
+
+(define (stack-ref index)
+  (fetch (address+ *stack* (cells->a-units (+ 1 index)))))
+
+(define (stack-set! index value)
+  (store! (address+ *stack* (cells->a-units (+ 1 index))) value))
+
+(define (pointer-to-stack-arguments)
+  (address+ *stack* (cells->a-units 1)))
+
+(define (remove-stack-arguments count)
+  (add-cells-to-stack! (- 0 count)))
+
+(define (address-at-header stob)
+  (address- (address-after-header stob) (cells->a-units 1)))
+
+;----------------
+; *STACK-LIMIT* is offset by DEFAULT-STACK-SPACE to make this test faster.
+
+(define (ensure-default-procedure-space! ensure-space)
+  (if (address< *stack* *stack-limit*)
+      (begin
+	(copy-stack-into-heap (ensure-space (current-stack-size)))
+	(if (address< *stack* *stack-limit*)
+	    (error "Couldn't get default procedure space (how can this happen?)"))))
+  0)
+
+; Compiler is not allowed to use more than one stack's worth of space for
+; any given procedure.
+
+(define (ensure-stack-space! space ensure-space)
+  (if (not (available-on-stack? space))
+      (begin
+	(copy-stack-into-heap (ensure-space (current-stack-size)))
+	(if (not (available-on-stack? space))
+	    (error "VM's stack is too small (how can this happen?)")))))
+
+(define (available-on-stack? space)
+  (> (+ (a-units->cells			; space on the stack
+	   (address-difference *stack* *stack-limit*))
+	default-stack-space)            ; allow for *stack-limit*'s offset
+     space))
+
+;----------------
+; Setting the current continuation.
+
+; Called when replacing the current continuation with a new one.
+
+(define (set-current-continuation! cont)
+  (if (continuation? cont)
+      (copy-continuation-from-heap! cont)
+      (reset-stack-pointer cont)))
+
+; Called when returning off of the end of the stack.
+
+(define (get-continuation-from-heap)
+  (continuation-cont *bottom-of-stack*))
+
+; Copy CONT from heap onto stack just above *BOTTOM-OF-STACK*, linking it
+; to *BOTTOM-OF-STACK* and *BOTTOM-OF-STACK* to CONT's continuation.
+
+(define (copy-continuation-from-heap! cont)
+  (assert (continuation? cont))
+  (let* ((top (address- (address-at-header *bottom-of-stack*)
+			(cells->a-units (+ 1 (continuation-length cont)))))
+         (new-cont (address->stob-descriptor (address1+ top))))
+    (add-copy-cont-from-heap-stats cont)
+    (set! *stack* (the-pointer-before top))
+    (set! *cont* new-cont)
+    (copy-memory! (address-at-header cont)
+		  top
+		  (cells->bytes (+ 1 (continuation-length cont))))
+    (set-continuation-cont! *bottom-of-stack* (continuation-cont new-cont))
+    (set-continuation-cont! new-cont *bottom-of-stack*)
+    new-cont))
+
+(define (push-continuation-on-stack template pc arg-count)
+  (add-continuation-stats arg-count)
+  (add-cells-to-stack! (+ 1 continuation-cells))
+  (store! (address1+ *stack*) (make-continuation-header arg-count))
+  (let ((cont (address->stob-descriptor (address2+ *stack*))))
+    (set-continuation-pc!       cont pc)
+    (set-continuation-template! cont template)
+    (set-continuation-env!      cont *env*)
+    (set-continuation-cont!     cont *cont*)
+    (set! *cont* cont)))
+
+(define make-continuation-header
+  (let ((type (enum stob continuation)))
+    (lambda (arg-count)
+      (make-header-immutable
+       (make-header type (cells->bytes (+ arg-count continuation-cells)))))))
+
+(define (pop-continuation-from-stack set-template!)
+  (let ((cont *cont*))
+    (set-template! (continuation-template cont)
+		   (continuation-pc       cont))
+    (set! *env*    (continuation-env      cont))
+    (set! *cont*   (continuation-cont     cont))
+    (set! *stack* (address+ (address-at-header cont)
+			    (cells->a-units continuation-cells)))))
+
+;----------------
+; Support for multiple-value returns.
+
+(define (peek-at-current-continuation)
+  (if (= *cont* *bottom-of-stack*)
+      (continuation-cont *bottom-of-stack*)
+      *cont*))
+
+(define (skip-current-continuation!)
+  (let ((next (continuation-cont *cont*)))
+    (if (= *cont* *bottom-of-stack*)
+	(set-continuation-cont! *cont* (continuation-cont next))
+	(set! *cont* next))))
+
+;----------------
+; Copying the stack into the heap because there is no more room on the
+; stack.  This preserves the continuation and then moves any arguments
+; down on top of the current continuation.
+
+(define (copy-stack-into-heap key)
+  (let ((arg-count (arguments-on-stack))
+	(top *stack*))
+    (preserve-continuation key (enum copy overflow))
+    (really-move-args-above-cont! arg-count top)))
+
+(define (arguments-on-stack)
+  (do ((p (address1+ *stack*) (address1+ p))
+       (i 0 (+ i 1)))
+      ((header? (fetch p))
+       (if (= (fetch p) argument-limit-marker)
+	   (- i 1)  ; marker is one past the original header location
+	   i))))
+
+; This is used by the environment code to mark environments that have been
+; migrated to the heap (their header gets clobbered during the of migration).
+; Any header type that is not normally found on the heap will work.
+
+(define argument-limit-marker (make-header (enum stob channel) 0))
+
+(define (really-move-args-above-cont! nargs top-of-args)
+  (let ((start-loc (the-pointer-before (address-at-header *cont*)))
+	(start-arg (address+ top-of-args (cells->a-units nargs))))
+    (do ((loc start-loc (the-pointer-before loc))
+	 (arg start-arg (the-pointer-before arg)))
+	((address<= arg top-of-args)
+	 (set! *stack* loc))
+      (store! loc (fetch arg)))))
+
+; Copy NARGS arguments from the top of the stack to just above CONT.
+; Used by OP/MOVE-ARGS-AND-CALL to implement tail-recursive calls.
+
+(define (move-args-above-cont! nargs)
+  (really-move-args-above-cont! nargs *stack*))
+
+; Migrating the current continuation into the heap, saving the environment
+; first.  The heap space needed is no more than the current stack size.
+
+(define current-continuation-size current-stack-size)
+
+(define (current-continuation key)
+  (preserve-continuation key (enum copy preserve)))
+
+(define (preserve-continuation key reason)
+  (if (false? *cont*)
+      false
+      (really-preserve-continuation key reason)))
+
+; 1. Preserve the current lexical environment
+; 2. Loop down the continuations copying them into the heap, including their
+;    lexical environments
+; 3. Copy the current continuation back onto the stack
+
+(define (really-preserve-continuation key reason)
+  (preserve-current-env-with-reason key reason)
+  (let ((end (continuation-cont *bottom-of-stack*)))
+    (let loop ((cont *cont*) (previous *bottom-of-stack*))
+      (cond ((vm-eq? cont *bottom-of-stack*)
+	     (set-continuation-cont! previous end))
+            (else
+             (if (within-stack? (continuation-env cont))
+                 (save-env-in-heap (continuation-env cont) cont key reason)
+		 0) ; for type inferencer (which could use some improvement)
+             (let ((new (header+contents->stob
+			 (stob-header cont)
+			 (address-after-header cont)
+			 key)))
+	       (add-preserve-cont-stats new reason)
+               (set-continuation-cont! previous new)
+               (loop (continuation-cont new) new))))))
+  (set! *cont* *bottom-of-stack*)  
+  (continuation-cont *bottom-of-stack*))
+
+;----------------
+; Tracing the stack for garbage collection - first trace any arguments pushed
+; above the current continuation, then loop down the continuations, tracing
+; each one along with its environment (if the environment has not yet been
+; done).
+
+(define *stack-warning?* #t)
+
+(define (trace-stack trace-locations! trace-stob-contents! trace-value)
+  (if *stack-warning?*
+      (do ((a *stack-begin* (address1+ a)))
+	  ((not (= stack-marker (fetch a)))
+	   (let ((unused (a-units->cells (address-difference a *stack-begin*))))
+	     (if (< unused stack-warning-limit)
+		 (begin
+		   (newline (current-error-port))
+		   (write-string "[Alert: stack overconsumption ("
+				 (current-error-port))
+		   (write-integer unused (current-error-port))
+		   (write-string "); please inform the Scheme 48 implementors]"
+				 (current-error-port))
+		   (newline (current-error-port))
+		   (set! *stack-warning?* #f)))))))
+  (let ((arg-count (arguments-on-stack)))
+    (trace-locations! (address1+ *stack*)
+		      (address+ *stack* (cells->a-units (+ arg-count 1)))))
+  (if (within-stack? *env*)
+      (trace-env *env* trace-stob-contents!)
+      (set! *env* (trace-value *env*)))
+  (let loop ((cont *cont*) (last-env 0))
+    (let ((env (continuation-env cont)))
+      (trace-stob-contents! cont)
+      (if (not (vm-eq? env last-env))
+	  (trace-env env trace-stob-contents!))
+      (if (not (vm-eq? cont *bottom-of-stack*))
+	  (loop (continuation-cont cont) env)))))
+
+(define (trace-env env trace-stob-contents!)
+  (let loop ((env env))
+    (if (within-stack? env)
+	(begin
+	  (trace-stob-contents! env)
+	  (loop (vm-vector-ref env 0))))))
+
+;----------------
+; Error reporting
+
+(define (report-continuation-uids current-template out)
+  (let ((not-first? (maybe-write-template current-template #f out)))
+    (let loop ((cont *cont*) (not-first? not-first?))
+      (if (continuation? cont)
+	  (loop (continuation-cont cont)
+		(maybe-write-template (continuation-template cont)
+				      not-first?
+				      out))))))
+
+(define (maybe-write-template template not-first? out)
+  (if (and (fixnum? (template-name template))
+	   (not (vm-eq? template (continuation-template *bottom-of-stack*))))
+      (begin
+	(if not-first?
+	    (write-string " <- " out))
+	(write-integer (extract-fixnum (template-name template)) out)
+	#t)
+      not-first?))
+
+;----------------
+; Collecting and printing statistics on stack usage
+
+(define collect-statistics? #f)
+
+(define *conts* 0)
+(define *conts-slots* 0)
+(define *conts-overflow* 0)
+(define *conts-overflow-slots* 0)
+(define *conts-preserved* 0)
+(define *conts-preserved-slots* 0)
+(define *conts-from-heap* 0)
+(define *conts-from-heap-slots* 0)
+
+(define *envs* 0)
+(define *envs-slots* 0)
+(define *envs-closed* 0)
+(define *envs-closed-slots* 0)
+(define *envs-overflow* 0)
+(define *envs-overflow-slots* 0)
+(define *envs-preserved* 0)
+(define *envs-preserved-slots* 0)
+
+(define (reset-stack-stats)
+  (cond (collect-statistics?
+	 (set! *conts* 0)
+	 (set! *conts-slots* 0)
+	 (set! *conts-overflow* 0)
+	 (set! *conts-overflow-slots* 0)
+	 (set! *conts-preserved* 0)
+	 (set! *conts-preserved-slots* 0)
+	 (set! *conts-from-heap* 0)
+	 (set! *conts-from-heap-slots* 0)
+
+	 (set! *envs* 0)
+	 (set! *envs-slots* 0)
+	 (set! *envs-closed* 0)
+	 (set! *envs-closed-slots* 0)
+	 (set! *envs-overflow* 0)
+	 (set! *envs-overflow-slots* 0)
+	 (set! *envs-preserved* 0)
+	 (set! *envs-preserved-slots* 0)
+	 )
+	(else 0)))
+
+(define (print-stack-stats port)
+  (if collect-statistics?
+      (really-print-stack-stats port)))
+
+(define (really-print-stack-stats port)
+  (let ((one-record (lambda (name count slots port)
+		      (newline port)
+		      (write-string "(" port)
+		      (write-string name port)
+		      (write-string " " port)
+		      ;(write-number count port)   ; don't have write-number!
+		      ;(write-number slots port)
+		      (write-string ")" port))))
+    (newline port)
+    (write-string "(continuations" port)
+    (one-record "made" *conts* *conts-slots* port)
+    (one-record "overflow" *conts-overflow* *conts-overflow-slots* port)
+    (one-record "preserved" *conts-preserved* *conts-preserved-slots* port)
+    (one-record "from-heap" *conts-from-heap* *conts-from-heap-slots* port)
+    (write-string ")" port)
+
+    (newline port)
+    (write-string "(environments" port)
+    (one-record "made" *envs* *envs-slots* port)
+    (one-record "closed" *envs-closed* *envs-closed-slots* port)
+    (one-record "overflow" *envs-overflow* *envs-overflow-slots* port)
+    (one-record "preserved" *envs-preserved* *envs-preserved-slots* port)
+    (write-string ")" port)
+    (newline port)
+    ))
+
+(define (add-continuation-stats arg-count)
+  (cond (collect-statistics?
+	 (set! *conts* (+ *conts* 1))
+	 (set! *conts-slots*
+	       (+ *conts-slots* (+ arg-count continuation-cells))))))
+
+
+(define (add-env-stats count)
+  (cond (collect-statistics?
+	 (set! *envs* (+ *envs* 1))
+	 (set! *envs-slots* (+ *envs-slots* (+ count 1))))))
+
+(define (add-copy-env-stats env reason)
+    (cond ((not collect-statistics?)
+	   (unspecific))
+	  ((= reason (enum copy closure))
+	   (set! *envs-closed* (+ *envs-closed* 1))
+	   (set! *envs-closed-slots*
+		 (+ *envs-closed-slots* (vm-vector-length env))))
+	  ((= reason (enum copy overflow))
+	   (set! *envs-overflow* (+ *envs-overflow* 1))
+	   (set! *envs-overflow-slots*
+		 (+ *envs-overflow-slots* (vm-vector-length env))))
+	  ((= reason (enum copy preserve))
+	   (set! *envs-preserved* (+ *envs-preserved* 1))
+	   (set! *envs-preserved-slots*
+		 (+ *envs-preserved-slots* (vm-vector-length env))))))
+
+(define (add-preserve-cont-stats new reason)
+  (cond ((not collect-statistics?)
+	 (unspecific))
+	((= reason (enum copy overflow))
+	 (set! *conts-overflow* (+ *conts-overflow* 1))
+	 (set! *conts-overflow-slots*
+	       (+ *conts-overflow-slots*
+		  (continuation-length new))))
+	((= reason (enum copy preserve))
+	 (set! *conts-preserved* (+ *conts-preserved* 1))
+	 (set! *conts-preserved-slots*
+	       (+ *conts-preserved-slots*
+		  (continuation-length new))))))
+
+(define (add-copy-cont-from-heap-stats cont)
+  (cond (collect-statistics?
+	 (set! *conts-from-heap* (+ *conts-from-heap* 1))
+	 (set! *conts-from-heap-slots* (+ *conts-from-heap-slots*
+					  (continuation-length cont))))))
diff --git a/scheme/vm/stob.scm b/scheme/vm/stob.scm
new file mode 100644
index 0000000..8ab8d81
--- /dev/null
+++ b/scheme/vm/stob.scm
@@ -0,0 +1,98 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+(define max-stob-size-in-cells
+  (+ max-stob-contents-size-in-cells
+     stob-overhead))
+
+(define (make-stob type len key)
+  (let ((addr (s48-allocate-space type (+ len (cells->bytes stob-overhead)) key)))
+    (store! addr (make-header type len))
+    (address->stob-descriptor (address+ addr (cells->bytes stob-overhead)))))
+
+(define (make-d-vector type len key)
+  (make-stob type (cells->bytes len) key))
+
+(define make-b-vector make-stob)
+
+; Used to copy stuff from the stack to the heap.
+
+(define (header+contents->stob header contents key)
+  (let* ((addr (s48-allocate-space (header-type header)
+				   (+ (header-length-in-bytes header)
+				      (cells->bytes stob-overhead))
+				   key))
+	 (data-addr (address+ addr (cells->bytes stob-overhead))))
+    (store! addr header)
+    (copy-memory! contents data-addr (header-length-in-bytes header))
+    (address->stob-descriptor data-addr)))
+
+(define (stob-type obj)
+  (header-type (stob-header obj)))
+
+(define (stob-of-type? obj type)
+  (and (stob? obj)
+       (= (stob-type obj) type)))
+
+; Immutability
+
+(define (immutable? thing)
+  (or (not (stob? thing))
+      (immutable-header? (stob-header thing))))
+
+(define (make-immutable! thing)
+  (if (not (immutable? thing))
+      (stob-header-set! thing (make-header-immutable (stob-header thing)))))
+
+; D-vectors (vectors of descriptors)
+
+(define (d-vector? obj)
+  (and (stob? obj)
+       (< (header-type (stob-header obj)) least-b-vector-type)))
+
+; The type in these routines is used only for internal error checking.
+
+(define (d-vector-length x)
+  (assert (d-vector? x))
+  (header-length-in-cells (stob-header x)))
+
+(define (d-vector-ref x index)
+  (assert (valid-index? index (d-vector-length x)))
+  (fetch (address+ (address-after-header x) (cells->a-units index))))
+
+(define (d-vector-set! x index value)
+  (assert (valid-index? index (d-vector-length x)))
+  (let ((addr (address+ (address-after-header x) (cells->a-units index))))
+    (s48-write-barrier x addr value)
+    (store! addr value)))
+
+(define (d-vector-init! x index value)
+  (assert (valid-index? index (d-vector-length x)))
+  (store! (address+ (address-after-header x) (cells->a-units index))
+          value))
+
+; B-vector = vector of bytes.
+
+(define (b-vector? obj)
+  (and (stob? obj)
+       (>= (header-type (stob-header obj))
+	   least-b-vector-type)))
+
+(define (b-vector-length x)
+  (assert (b-vector? x))
+  (header-length-in-bytes (stob-header x)))
+
+(define (b-vector-ref b-vector index)
+  (assert (valid-index? index (b-vector-length b-vector)))
+  (fetch-byte (address+ (address-after-header b-vector) index)))
+
+(define (b-vector-set! b-vector index value)
+  (assert (valid-index? index (b-vector-length b-vector)))
+  (store-byte! (address+ (address-after-header b-vector) index) value))
+
+; Various utilities
+
+(define (valid-index? index len)
+  (and (>= index 0) (< index len)))
+
+
diff --git a/scheme/vm/struct.scm b/scheme/vm/struct.scm
new file mode 100644
index 0000000..75ebd13
--- /dev/null
+++ b/scheme/vm/struct.scm
@@ -0,0 +1,157 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; This is file struct.scm.
+
+; This file defines a level of abstraction for storage somewhat higher
+; than that of d-vectors and b-vectors: pairs, symbols, and other datatypes.
+
+(define (stob-maker type maker)
+  (lambda (length key)
+    (maker type length key)))
+
+(define (stob-predicate type)
+  (lambda (obj) (stob-of-type? obj type)))
+
+; data for these comes from STOB-DATA in arch.scm
+
+(define-shared-primitive-data-type pair #t)
+(define-shared-primitive-data-type symbol #t #f
+  make-symbol                           		; hidden from RTS
+  ()
+  (symbol-next set-symbol-next!))       		; hidden from RTS
+(define-shared-primitive-data-type closure #f #t)
+(define-shared-primitive-data-type location)
+(define-shared-primitive-data-type weak-pointer)
+(define-shared-primitive-data-type shared-binding #f #f
+  #f
+  ()
+  (shared-binding-next set-shared-binding-next!))	; hidden from RTS
+(define-shared-primitive-data-type port)
+(define-shared-primitive-data-type channel #f #f
+  make-channel                           		; hidden from RTS
+  (;; these setters are hidden from the RTS
+   (channel-status    set-channel-status!)
+   (channel-id        set-channel-id!)
+   (channel-os-index  set-channel-os-index!))
+  ;; none of these are visible to the RTS
+  (channel-next      set-channel-next!)
+  (channel-os-status set-channel-os-status!))
+
+; Vectors and so on
+
+(define-vector-data-type vector #t)
+(define-vector-data-type record)
+(define-vector-data-type extended-number)
+(define-vector-data-type continuation)
+(define-vector-data-type template)
+
+(define (vm-vector-fill! v val)
+  (do ((i 0 (+ i 1)))
+      ((= i (vm-vector-length v)) v)
+    (vm-vector-set! v i val)))
+
+(define (continuation-cont     c) (continuation-ref c 0))
+(define (continuation-pc       c) (continuation-ref c 1))
+(define (continuation-template c) (continuation-ref c 2))
+(define (continuation-env      c) (continuation-ref c 3))
+
+; Continuations are only initialized
+
+(define (set-continuation-cont!     c val) (d-vector-init! c 0 val))
+(define (set-continuation-pc!       c val) (d-vector-init! c 1 val))
+(define (set-continuation-template! c val) (d-vector-init! c 2 val))
+(define (set-continuation-env!      c val) (d-vector-init! c 3 val))
+
+(define continuation-cells 4)
+
+(define (template-code tem) (template-ref tem 0))
+(define (template-name tem) (template-ref tem 1))
+
+; The VM needs a few templates for various obscure purposes.
+
+(define (make-template-containing-ops op1 op2 key)
+  (let ((temp (make-template 2 key))
+        (code (make-code-vector 2 key)))
+    (template-set! temp 0 code)
+    (code-vector-set! code 0 op1)
+    (code-vector-set! code 1 op2)
+    temp))
+
+(define (op-template-size op-count)
+  (+ (template-size 2) (code-vector-size op-count)))
+
+; Code vectors
+
+(define make-code-vector   (stob-maker (enum stob byte-vector) make-b-vector))
+(define code-vector?       (stob-predicate (enum stob byte-vector)))
+(define code-vector-length b-vector-length)
+(define code-vector-ref    b-vector-ref)
+(define code-vector-set!   b-vector-set!)
+
+(define (code-vector-size len)
+  (+ stob-overhead (bytes->cells len)))
+
+; Strings are presented as being one character shorter than they really
+; are to hide the null character at the end.
+
+(define (vm-make-string length key)
+  (let ((string (make-b-vector (enum stob string) (+ length 1) key)))
+    (b-vector-set! string length 0)
+    string))
+(define vm-string?       (stob-predicate (enum stob string)))
+(define vm-string-length (lambda (x) (- (b-vector-length x) 1)))
+(define vm-string-ref    (lambda (s i) (ascii->char (b-vector-ref s i))))
+(define vm-string-set!   (lambda (s i c) (b-vector-set! s i (char->ascii c))))
+
+(define (vm-string-size length)
+  (+ stob-overhead (bytes->cells (+ 1 length))))
+
+(define (enter-string string key)           ; used by VMIO on startup
+  (let ((z (string-length string)))
+    (let ((v (vm-make-string z key)))
+      (do ((i 0 (+ i 1)))
+          ((>= i z) v)
+        (vm-string-set! v i (string-ref string i))))))
+
+; This depends on our having 0 bytes at the end of strings.
+
+(define (extract-string string)         ; used by OPEN
+  (fetch-nul-terminated-string (address-after-header string)))
+  
+(define (vm-string=? s1 s2)
+  (assert (and (vm-string? s1) (vm-string? s2)))
+  (let ((len (b-vector-length s1)))
+    (and (= len (b-vector-length s2))
+	 (memory-equal? (address-after-header s1)
+			(address-after-header s2)
+			len))))
+
+; Number predicates
+
+(define bignum?       (stob-predicate (enum stob bignum)))
+(define ratnum?       (stob-predicate (enum stob ratnum)))
+(define double?       (stob-predicate (enum stob double)))
+
+; Hashing
+
+; The hash function used here is to take the sum of the ascii values
+; of the characters in the string, modulo the symbol table size.
+;
+; This hash function was also compared against some others, e.g.
+; adding in the length as well, and taking only the odd or only the
+; even characters.  It fared about the same as adding the length, and
+; much better than examining only every other character.
+;
+; Perhaps a hash function that is sensitive to the positions of the
+; characters should be tried?  (Consider CADDR, CDADR, CDDAR.)
+;
+; Of course, if we switched to rehashing, a prime modulus would be
+; important.
+
+(define (vm-string-hash s)
+  (let ((n (vm-string-length s)))
+    (do ((i 0 (+ i 1))
+         (h 0 (+ h (char->ascii (vm-string-ref s i)))))
+        ((>= i n) h))))
+
diff --git a/scheme/vm/symbol.scm b/scheme/vm/symbol.scm
new file mode 100644
index 0000000..509f73c
--- /dev/null
+++ b/scheme/vm/symbol.scm
@@ -0,0 +1,63 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+; The symbol table, which is just a string table full of symbols.
+
+(define *the-symbol-table*)
+
+(define-consing-primitive intern (string->)
+  (lambda (ignore)
+    (+ vm-symbol-size
+       hash-table-entry-size))
+  (let ((searcher (table-searcher vm-symbol->string
+				  vm-symbol-next
+				  vm-make-symbol)))
+    (lambda (string key)
+      (searcher *the-symbol-table* string key)))
+  return)
+
+; Using the regular set-...-next! procedures in the cleanup procedure is
+; unfortunate, because they go through the write barrier.  Of course, we
+; could disable that for these setters, since the symbol table has to be
+; checked every GC anyway.
+
+; Copy the table and remove any unreachable symbols.  This is exported for
+; use when writing an image.
+
+(define s48-copy-symbol-table
+  (let ((cleaner! (table-cleaner vm-symbol-next vm-set-symbol-next!)))
+    (lambda ()
+      (let ((new (s48-trace-value *the-symbol-table*)))
+	(cleaner! new)
+	new))))
+
+(add-post-gc-cleanup!
+  (lambda ()
+    (set! *the-symbol-table* (s48-copy-symbol-table))))
+
+; There is no symbol table in images created by the static linker.
+
+(define (install-symbols!+gc symbol-table)
+  (if (eq? symbol-table false)
+      (build-symbol-table+gc)
+      (set! *the-symbol-table* symbol-table)))
+
+; Create the symbol table and then add to it all currently-extant symbols.
+
+(define (build-symbol-table+gc)
+  (set! *the-symbol-table* (make-hash-table (ensure-space hash-table-size)))
+  (let ((symbols (let ((maybe (s48-find-all (enum stob symbol))))
+		   (if (eq? maybe false)
+		       (begin
+			 (collect)
+			 (let ((maybe (s48-find-all (enum stob symbol))))
+			   (if (eq? maybe false)
+			       (error "insufficient heap space to build symbol table"))
+			   maybe))
+		       maybe))))
+    (natural-for-each (lambda (i)
+			(symbol-table-add! *the-symbol-table*
+					   (vm-vector-ref symbols i)))
+		      (vm-vector-length symbols))))
+
+(define symbol-table-add! (table-adder vm-symbol->string vm-set-symbol-next!))
diff --git a/scheme/vm/vm-tables.scm b/scheme/vm/vm-tables.scm
new file mode 100644
index 0000000..25b0f34
--- /dev/null
+++ b/scheme/vm/vm-tables.scm
@@ -0,0 +1,109 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; String hash tables for managing three tables:
+;  the symbol table : string -> symbol
+;  exported-bindings : string -> shared-binding
+;  imported-bindings : string -> shared-binding
+
+; Size of the hash vectors (is this a reasonable size?).
+
+(define hash-table-slots 1024)
+
+(define hash-table-size (vm-vector-size hash-table-slots))
+
+; All hash table values are required to have their own link fields.
+
+(define hash-table-entry-size 0)
+
+(define (hash-table-index string)
+  (bitwise-and (vm-string-hash string)
+	       (- hash-table-slots 1)))
+
+; All buckets are initially false.
+
+(define (make-hash-table key)
+  (let ((table (vm-make-vector hash-table-slots key)))
+    (natural-for-each (lambda (index)
+			(vm-vector-set! table index false))
+		      hash-table-slots)
+    table))
+
+; Return a procedure for adding FOO's to tables.
+
+(define (table-adder foo-string set-foo-next!)
+  (lambda (table foo)
+    (let ((index (hash-table-index (foo-string foo))))
+      (set-foo-next! foo (vm-vector-ref table index))
+      (vm-vector-set! table index foo))))
+
+; Return a function for looking up strings in a Foo table.  A new Foo is
+; made if none is found.
+
+(define (table-searcher foo-string foo-next make-foo)
+  (lambda (table string key)
+    (let* ((index (hash-table-index string))
+           (bucket (vm-vector-ref table index)))
+      (let loop ((foo bucket))
+        (cond ((vm-eq? foo false)
+               (let ((new (make-foo string bucket key)))
+                 (vm-vector-set! table index new)
+                 new))
+              ((vm-string=? string (foo-string foo))
+	       foo)
+              (else
+	       (loop (foo-next foo))))))))
+
+; Same thing, except we remove the entry if it is found.
+
+(define (table-remover foo-string foo-next set-foo-next!)
+  (lambda (table string)
+    (let* ((index (hash-table-index string))
+           (bucket (vm-vector-ref table index)))
+      (let loop ((previous-foo false) (foo bucket))
+	(cond ((vm-eq? foo false)
+	       (unspecific))
+	      ((not (vm-string=? string (foo-string foo)))
+	       (loop foo (foo-next foo)))
+	      ((vm-eq? previous-foo false)
+	       (vm-vector-set! table index (foo-next foo)))
+	      (else
+	       (set-foo-next! previous-foo (foo-next foo))))))))
+
+; Return a procedure that will apply PROC to every element of TABLE.
+
+(define (table-walker foo-next)
+  (lambda (proc table)
+    (natural-for-each (lambda (index)
+			(let loop ((entry (vm-vector-ref table index)))
+			  (if (not (vm-eq? entry false))
+			      (begin
+				(proc entry)
+				(loop (foo-next entry))))))
+		      hash-table-slots)))
+
+; Copy a table, treating the entries weakly.
+
+(define (table-cleaner foo-next set-foo-next!)
+  (let ((entry-cleaner (entry-cleaner foo-next set-foo-next!)))
+    (lambda (table)
+      (let ((table (s48-trace-value table)))
+	(natural-for-each
+	  (lambda (index)
+	    (vm-vector-set! table
+			    index
+			    (entry-cleaner (vm-vector-ref table index))))
+	  hash-table-slots)))))
+  
+(define (entry-cleaner foo-next set-foo-next!)
+  (lambda (foo)
+    (let loop ((foo foo) (okay false))
+      (if (vm-eq? foo false)
+	  okay
+	  (loop (foo-next foo)
+		(if (s48-extant? foo)
+		    (let ((new-foo (s48-trace-value foo)))
+		      (set-foo-next! new-foo okay)
+		      new-foo)
+		    okay))))))
+
diff --git a/scheme/vm/vm-utilities.scm b/scheme/vm/vm-utilities.scm
new file mode 100644
index 0000000..c1a4000
--- /dev/null
+++ b/scheme/vm/vm-utilities.scm
@@ -0,0 +1,47 @@
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+
+(define (adjoin-bits high low k)
+  (+ (shift-left high k) low))
+
+(define (low-bits n k)
+  (bitwise-and n (- (shift-left 1 k) 1)))
+
+(define high-bits arithmetic-shift-right)
+
+(define unsigned-high-bits logical-shift-right)
+
+(define (digit? ch)
+  (let ((ch (char->ascii ch)))
+    (and (>= ch (char->ascii #\0))
+	 (<= ch (char->ascii #\9)))))
+
+(define (vector+length-fill! v length x)
+  (do ((i 0 (+ i 1)))
+      ((>= i length))
+    (vector-set! v i x)))
+
+; Apply PROC to 0 ... N-1.
+
+(define (natural-for-each proc n)
+  (do ((i 0 (+ i 1)))
+      ((= i n))
+    (proc i)))
+
+;----------------
+
+(define (error? status)
+  (not (eq? status (enum errors no-errors))))
+
+(define (write-error-string string)
+  (write-string string (current-error-port)))
+
+(define (write-error-integer integer)
+  (write-integer integer (current-error-port)))
+
+(define (write-error-newline)
+  (write-char #\newline (current-error-port)))
+
+(define (error-message string)
+  (write-error-string string)
+  (write-error-newline))
diff --git a/scheme/vm/vmio.scm b/scheme/vm/vmio.scm
new file mode 100644
index 0000000..4c8a2bf
--- /dev/null
+++ b/scheme/vm/vmio.scm
@@ -0,0 +1,341 @@
+; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
+; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
+
+; This is file vmio.scm.
+
+; *vm-channels* is a vector of descriptors for open channels.
+
+(define *number-of-channels* 100)
+
+(define *vm-channels*)
+
+(define closed-status
+  (enter-fixnum (enum channel-status-option closed)))
+(define input-status
+  (enter-fixnum (enum channel-status-option input)))
+(define output-status
+  (enter-fixnum (enum channel-status-option output)))
+(define special-input-status
+  (enter-fixnum (enum channel-status-option special-input)))
+(define special-output-status
+  (enter-fixnum (enum channel-status-option special-output)))
+
+(define (input-channel? channel)
+  (= (channel-status channel) input-status))
+
+(define (output-channel? channel)
+  (= (channel-status channel) output-status))
+
+(define (open? channel)
+  (not (= (channel-status channel) closed-status)))
+
+(define (initialize-i/o-system+gc)
+  (set! *number-of-channels*
+	(max *number-of-channels*
+	     (+ 1
+		(max (input-port->channel (current-input-port))
+		     (max (output-port->channel (current-output-port))
+			  (output-port->channel (current-error-port)))))))
+  (set! *vm-channels* (make-vector *number-of-channels*
+				   (input-port->channel (current-input-port))))
+  (set! *pending-channels-head* false)
+  (set! *pending-channels-tail* false)
+  (if (null-pointer? *vm-channels*)
+      (error "out of memory, unable to continue"))
+  (vector+length-fill! *vm-channels* *number-of-channels* false)
+  (let ((key (ensure-space (* 3 (+ channel-size
+				   (vm-string-size
+				     (string-length "standard output")))))))
+    (values (make-initial-channel (input-port->channel (current-input-port))
+				  input-status
+				  "standard input"
+				  key)
+	    (make-initial-channel (output-port->channel (current-output-port))
+				  output-status
+				  "standard output"
+				  key)
+	    (make-initial-channel (output-port->channel (current-error-port))
+				  output-status
+				  "standard error"
+				  key))))
+
+(define (make-initial-channel channel status name key)
+  (let ((vm-channel (make-channel status
+				  (enter-string name key)
+				  (enter-fixnum channel)
+				  false    ; next
+				  false    ; os-status
+				  key)))
+    (vector-set! *vm-channels* channel vm-channel)
+    vm-channel))
+
+(define (os-index->channel index)
+  (vector-ref *vm-channels* index))
+
+; Make a new channel.  The os-index is used to handle I/O-completion interrupts
+; so we have to ensure that there is at most one channel using each index.
+
+(define (make-registered-channel mode id os-index key)
+  (cond ((not (or (< os-index *number-of-channels*)
+		  (add-more-channels os-index)))
+	 (values false (enum exception out-of-memory)))
+	((false? (vector-ref *vm-channels* os-index))
+	 (let ((channel (make-channel (enter-fixnum mode)
+				      id
+				      (enter-fixnum os-index)
+				      false   ; next
+				      false   ; os-status
+				      key)))
+	   (vector-set! *vm-channels* os-index channel)
+	   (values channel
+		   (enum exception out-of-memory)))) ; exception is ignored
+	(else
+	 (values false (enum exception channel-os-index-already-in-use)))))
+
+; Called from outside the VM.  It's up to the caller to be GC-safe.
+; Returns FALSE if anything goes wrong.
+
+(define (s48-add-channel mode id os-index)
+  (receive (channel status)
+      (make-registered-channel (extract-fixnum mode)
+			       id
+			       os-index
+			       (ensure-space channel-size))
+    (if (channel? channel)
+	channel
+	(enter-fixnum status))))
+
+; Called from outside to change the os-index of a particular channel.
+
+(define (s48-set-channel-os-index channel os-index)
+  (cond ((not (or (< os-index *number-of-channels*)
+		  (add-more-channels os-index)))
+	 (enter-fixnum (enum exception out-of-memory)))
+	((false? (vector-ref *vm-channels* os-index))
+	 (let ((old-index (extract-fixnum (channel-os-index channel))))
+	   (if (vm-eq? (channel-os-status channel)
+		       true)
+	       (enqueue-channel! old-index (channel-abort old-index)))
+	   (vector-set! *vm-channels* old-index false)
+	   (vector-set! *vm-channels* os-index channel)
+	   (set-channel-os-index! channel (enter-fixnum os-index))
+	   true))
+	(else
+	 (enter-fixnum (enum exception channel-os-index-already-in-use)))))
+
+; Extend the vector of channels.
+
+(define (add-more-channels index)
+  (let* ((new-count (max (+ index 1)
+			 (+ *number-of-channels* 8)))
+	 (old-count *number-of-channels*)
+	 (new-vm-channels (make-vector new-count (vector-ref *vm-channels* 0))))
+    (cond ((null-pointer? new-vm-channels)
+	   #f)
+	  (else
+	   (do ((i 0 (+ i 1)))
+	       ((= i *number-of-channels*))
+	     (vector-set! new-vm-channels i (vector-ref *vm-channels* i)))
+	   (do ((i *number-of-channels* (+ i 1)))
+	       ((= i new-count))
+	     (vector-set! new-vm-channels i false))
+	   (deallocate *vm-channels*)
+	   (set! *vm-channels* new-vm-channels)
+	   (set! *number-of-channels* new-count)
+	   #t))))
+
+; We abort any operation pending on the channel and then close it, freeing
+; up the index.  The status from the OS's close function is returned.
+
+(define (close-channel! channel)
+  (let ((os-index (extract-fixnum (channel-os-index channel))))
+    (if (vm-eq? (channel-os-status channel)
+		true)
+	(enqueue-channel! os-index (channel-abort os-index)))
+    (let ((status (if (or (= input-status (channel-status channel))
+			  (= special-input-status (channel-status channel)))
+		      (close-input-channel os-index)
+		      (close-output-channel os-index))))
+      (vector-set! *vm-channels* os-index false)
+      (set-channel-status! channel closed-status)
+      status)))
+
+; Called from outside the VM.  Closes the channel at OS-INDEX, should we have
+; such.
+
+(define (s48-close-channel os-index)
+  (if (and (<= 0 os-index)
+	   (< os-index *number-of-channels*)
+	   (channel? (os-index->channel os-index)))
+      (close-channel! (os-index->channel os-index)))
+  (unspecific))
+
+; Called to close an OS channel when we have been unable to make the
+; corresponding Scheme channel.
+
+(define (close-channel-index! index name mode)
+  (let ((status (if (input-channel-status? mode)
+		    (close-input-channel index)
+		    (close-output-channel index))))
+    (if (error? status)
+	(channel-close-error status index name))))
+
+(define (input-channel-status? mode)
+  (or (= mode (enum channel-status-option input))
+      (= mode (enum channel-status-option special-input))))
+
+(define (channel-close-error status index id)
+  (write-error-string "Error: ")
+  (write-error-string (error-string status))
+  (write-error-newline)
+  (write-error-string " while closing port ")
+  (if (vm-string? id)
+      (write-error-string (extract-string id))
+      (write-error-integer (extract-fixnum index)))
+  (write-error-newline))
+
+; Return a list of the open channels, for the opcode of the same name.
+; Not that it's important, but the list has the channels in order of
+; their os-indexes.
+
+(define (open-channels-list)
+  (let ((key (ensure-space (* vm-pair-size *number-of-channels*))))
+    (do ((i (- *number-of-channels* 1) (- i 1))
+	 (res null
+	      (let ((channel (vector-ref *vm-channels* i)))
+		(if (channel? channel)
+		    (vm-cons channel res key)
+		    res))))
+	((= i -1)
+	 res))))
+
+;----------------------------------------------------------------
+; Handling i/o-completion interrupts
+; Currently, because the GC may move buffers, strings, etc. around, the OS
+; must buffer the data while waiting for i/o to complete.
+;
+; Unix: the i/o completion just means that the channel is ready; no characters
+; are ever transfered asynchronously.
+;
+; DOS/Windows: no non-blocking i/o of any kind.
+;
+; WindowsNT: we will need a fancier GC or something.
+
+; These are a queue of channels with pending interrupts
+
+(define *pending-channels-head* false)
+(define *pending-channels-tail* false)
+
+(define (channel-queue-empty?)
+  (false? *pending-channels-head*))
+
+(define (enqueue-channel! index status)
+  (let ((channel (os-index->channel index)))
+    (set-channel-os-status! channel (enter-fixnum status))
+    (cond ((not (false? (channel-next channel))) ; already queued (how?)
+	   (unspecific))  ; for the type checker
+	  ((false? *pending-channels-head*)
+	   (set! *pending-channels-head* channel)
+	   (set! *pending-channels-tail* channel))
+	  (else
+	   (set-channel-next! *pending-channels-tail* channel)
+	   (set! *pending-channels-tail* channel)))))
+
+(define (dequeue-channel!)
+  (let* ((channel *pending-channels-head*)
+	 (next (channel-next channel)))
+    (set! *pending-channels-head* next)
+    (set-channel-next! channel false)
+    (if (false? next)
+	(set! *pending-channels-tail* false))
+    channel))
+
+; See if a the OS has already finished with CHANNEL and return its status
+; if it has.  If not, call the OS and have it abort the channel's current
+; operation.
+
+(define (vm-channel-abort channel)
+  (let ((head *pending-channels-head*))
+    (cond ((false? head)
+	   (set-channel-os-status! channel false) ; no longer pending
+	   (enter-fixnum (channel-abort
+			  (extract-fixnum (channel-os-index channel)))))
+	  ((vm-eq? channel head)
+	   (dequeue-channel!)
+	   (channel-os-status channel))
+	  (else
+	   (let loop ((ch (channel-next head)) (prev head))
+	     (cond ((false? ch)
+		    (set-channel-os-status! channel false) ; no longer pending
+		    (enter-fixnum (channel-abort
+				    (extract-fixnum (channel-os-index channel)))))
+		   ((vm-eq? ch channel)
+		    (if (vm-eq? ch *pending-channels-tail*)
+			(set! *pending-channels-tail* prev))
+		    (set-channel-next! prev (channel-next ch))
+		    (set-channel-next! ch false)
+		    (channel-os-status ch))
+		   (else
+		    (loop (channel-next ch) ch))))))))
+
+(define (trace-io trace-value)
+  (set! *pending-channels-head* (trace-value *pending-channels-head*))
+  (set! *pending-channels-tail* (trace-value *pending-channels-tail*)))
+
+;----------------------------------------------------------------
+; Automatically closing channels.
+
+; The following is called after the GC finishes.
+
+(define (close-untraced-channels!)
+  (do ((i 0 (+ i 1)))
+      ((= i *number-of-channels*) #f)
+    (let ((channel (vector-ref *vm-channels* i)))
+      (if (not (false? channel))
+	  (let* ((header (stob-header channel))
+		 (new (cond ((stob? header)  ; channel was copied
+			     header)
+			    ((open? channel) ; channel was not copied
+			     (close-channel-noisily! channel)
+			     false)
+			    (else
+			     false))))
+	    (vector-set! *vm-channels* i new))))))
+
+(define (close-channel-noisily! channel)
+  (let ((status (close-channel! channel))
+	(id (let ((id (channel-id channel)))
+	      (cond ((fixnum? id)
+		     id)
+		    ((stob? (stob-header id))
+		     (stob-header id))
+		    (else
+		     id)))))
+    (if (error? status)
+	(channel-close-error status (channel-os-index channel) id))
+    (write-error-string "Channel closed: ")
+    (if (fixnum? id)
+	(write-error-integer (extract-fixnum id))
+	(write-error-string (extract-string id)))
+    (write-error-string " ")
+    (write-error-integer (extract-fixnum (channel-os-index channel)))
+    (write-error-newline)))
+
+; Mark channels in about-to-be-dumped heaps as closed.
+
+(define (s48-mark-traced-channels-closed!)
+  (do ((i 0 (+ i 1)))
+      ((= i *number-of-channels*))
+    (let ((channel (vector-ref *vm-channels* i)))
+      (if (not (false? channel))
+	  (let ((header (stob-header channel)))
+	    (if (stob? header)    ; channel was copied
+		(begin
+		  (write-error-string "Channel closed in dumped image: ")
+		  (if (fixnum? (channel-id channel))
+		      (write-error-integer (extract-fixnum (channel-id channel)))
+		      (write-error-string (extract-string (channel-id channel))))
+		  (write-error-newline)
+		  (set-channel-status! header closed-status)
+		  (set-channel-os-index! header (enter-fixnum -1))))))))
+  (unspecific))